Added views, formlets, and handlers for nutrient target management.

author: Marius Peter <dev@marius-peter.com> 2025-10-21 21:36:09 +0200
committer: Marius Peter <dev@marius-peter.com> 2025-10-21 21:36:09 +0200
commit: 86b5343292e852155dab10fc8db39c2dd2b932eb (patch)
tree: be7da4f70ecf803aec3b3e3498d6e2ed6e98003f
parent: 9bdb71dfc7d10b20bf8f78823194f4e114f8fa16 (diff)
3 files changed, 127 insertions, 26 deletions
diff --git a/formlets.rkt b/formlets.rkt
index 406a54a..d0067e3 100644
--- a/formlets.rkt
+++ b/formlets.rkt
@@ -1,11 +1,14 @@
 #lang racket
 
-(provide measurements-formlet)
+(provide measurements-formlet
+         targets-formlet)
 
 (require gregor
          web-server/http
          web-server/formlets
-         "models/nutrient.rkt")
+         "models/nutrient.rkt"
+         "models/crop.rkt"
+         "models/crop-requirement.rkt")
 
 
 (define date-formlet
@@ -26,7 +29,7 @@
                           [id ,(number->string id)]
                           [step "0.1"]
                           [placeholder ,(nutrient-name nutrient)])))
-  (define input-label `(label ((for ,(number->string id))) ,(nutrient-name nutrient)))
+  (define input-label `(label ([for ,(number->string id)]) ,(nutrient-name nutrient)))
   (formlet
    (#%#
     (div ([class "form-floating mb-3"])
@@ -51,3 +54,43 @@
    (let ([measured-on (first measured-on*)]
          [measurements (filter pair? measurements*)]) ; drop #f’s from empty values
      (values measured-on measurements))))
+
+(define (crop-requirement-formlet requirement)
+  (define id (crop-requirement-id requirement))
+  (define profile (crop-requirement-profile requirement))
+  (define maybe-crop (crop-requirement-crop-id requirement))
+  (define crop (if maybe-crop (crop-name (get-crop #:id maybe-crop)) #f))
+  (define number-input
+    (input #:type "number"
+           #:attributes `([class "form-control"]
+                          [id ,(number->string id)]
+                          [step "1"]
+                          [placeholder ,profile])))
+  (define input-label `(label ([for ,(number->string id)])
+                              ,(if crop
+                                   (format "~a (~a)" crop profile)
+                                   (format "~a" profile))))
+  (formlet
+   (#%#
+    (div ([class "form-floating mb-3"])
+         ,{=> number-input requirement-proportion-b}
+         ,input-label))
+   (let ([requirement-proportion (string->number
+                                  (bytes->string/utf-8
+                                   (binding:form-value requirement-proportion-b)))])
+     (and requirement-proportion (cons requirement requirement-proportion)))))
+
+(define (targets-formlet)
+  (formlet*
+   (#%#
+    `(div ([class "mb-3"])
+          (h5 "Date ciblée")
+          ,{=>* date-formlet effective-on*})
+    `(div ([class "mb-3"])
+          (h5 "Valeurs cibles")
+          ,@(for/list ([requirement (get-crop-requirements)])
+              {=>* (crop-requirement-formlet requirement) requirements*}))
+    {=>* (submit "Enregistrer la cible" #:attributes '([class "btn btn-primary"])) _})
+   (let ([effective-on (first effective-on*)]
+         [requirements (filter pair? requirements*)]) ; drop #f’s from empty values
+     (values effective-on requirements))))
diff --git a/handlers.rkt b/handlers.rkt
index 42e4a76..aa380aa 100644
--- a/handlers.rkt
+++ b/handlers.rkt
@@ -8,8 +8,22 @@
          "views.rkt"
          "formlets.rkt"
          "models/nutrient.rkt"
-         "models/nutrient-measurement.rkt")
+         "models/nutrient-measurement.rkt"
+         "models/nutrient-target.rkt"
+         "models/crop-requirement.rkt")
 
+(define-values (app-dispatch _)
+  (dispatch-rules
+   ;; Nutrient measurements
+   [("measurement" "new")     #:method "get"  new-measurement]
+   [("measurement" "create")  #:method "post" create-measurement]
+   [("measurement" "destroy") #:method "post" destroy-measurement]
+   ;; Nutrient targets
+   [("target" "new")          #:method "get"  new-target]
+   [("target" "create")       #:method "post" create-target]
+   ;; Index
+   [("")                      #:method "get"  index]
+   [else fallback]))
 
 (define (index _)
   (define measurements (get-nutrient-measurements))
@@ -17,6 +31,9 @@
    #:preamble #"<!DOCTYPE html>"
    (index-page measurements)))
 
+
+;; Nutrient measurements
+
 (define (new-measurement _)
   (response/xexpr
    #:preamble #"<!DOCTYPE html>"
@@ -29,20 +46,42 @@
   (redirect-to "/"))
 
 (define (destroy-measurement req)
-  (define-values (measured-on measurements)
-    (formlet-process (measurements-formlet) req))
-  (create-nutrient-measurement! measured-on measurements)
+  (delete-nutrient-measurement! req)
   (redirect-to "/"))
 
-(define (fallback req)
+
+;; Nutrient targets
+
+(define (new-target _)
   (response/xexpr
    #:preamble #"<!DOCTYPE html>"
-   (fallback-page 404)))
+   (new-target-page)))
 
-(define-values (app-dispatch app-url)
-  (dispatch-rules
-   [("measurement" "new")     #:method "get"  new-measurement]
-   [("measurement" "create")  #:method "post" create-measurement]
-   [("measurement" "destroy") #:method "post" destroy-measurement]
-   [("")                      #:method "get"  index]
-   [else fallback]))
+(define (create-target req)
+  (define-values (effective-on crop-requirement-mix)
+    (formlet-process (targets-formlet) req))
+
+  (define (average-nutrient-values mix)
+    (define totals
+      (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))])
+          (define n (car nv))
+          (define v (cdr nv))
+          (hash-update acc n
+                       (λ (old) (+ old (* v percentage)))
+                       (λ () (* v percentage))))))
+    (for/list ([(k v) (in-hash totals)])
+      (cons k v)))
+
+  (define target-nutrient-values (average-nutrient-values crop-requirement-mix))
+  (pretty-display target-nutrient-values)
+  (create-nutrient-target! effective-on target-nutrient-values)
+  (redirect-to "/"))
+
+(define (fallback _)
+  (response/xexpr
+   #:preamble #"<!DOCTYPE html>"
+   (fallback-page 404)))
diff --git a/views.rkt b/views.rkt
index d78c370..12b5d1a 100644
--- a/views.rkt
+++ b/views.rkt
@@ -2,12 +2,14 @@
 
 (provide index-page
          new-measurement-page
+         new-target-page
          fallback-page)
 
 (require web-server/formlets
          "formlets.rkt"
          "models/nutrient.rkt"
-         "models/nutrient-measurement.rkt")
+         "models/nutrient-measurement.rkt"
+         "models/nutrient-target.rkt")
 
 
 (define (page-template title body-xexpr)
@@ -77,19 +79,26 @@
      (a ([class "btn btn-primary mb-3"] [href "/target/new"]) "Créer une cible")
      (table ([class "table"])
             (tr (th "Nutriment")
-                (th ([class "text-end"]) "Dernière Cible")
                 (th ([class "text-end"]) "Dernier Relevé")
+                (th ([class "text-end"]) "Dernière Cible")
                 (th ([class "text-end"]) "Delta (%)"))
             ,@(for/list ([n (get-nutrients)])
-                (define latest-target (+ (get-latest-nutrient-measurement-value n) 1))
-                (define latest-value (get-latest-nutrient-measurement-value n))
-                (define delta (* 100
-                                 (/ (- latest-target latest-value)
-                                    latest-target)))
+                (define latest-target (get-latest-nutrient-target-value n))
+                (define latest-measurement (get-latest-nutrient-measurement-value n))
+                (define delta-percentage (cond
+                                           [(zero? latest-target)
+                                            -100]
+                                           [(zero? latest-measurement)
+                                            100]
+                                           [(number? latest-target)
+                                            (* 100
+                                               (/ (- latest-target latest-measurement)
+                                                  latest-measurement))]
+                                           [else #f]))
                 `(tr (td ,(nutrient-name n))
-                     (td ([class "text-end"]) ,(round 2 latest-target))
-                     (td ([class "text-end"]) ,(round 2 latest-value))
-                     (td ([class "text-end"]) ,(round 1 delta)))))
+                     (td ([class "text-end"]) ,(if latest-measurement (round 2 latest-measurement) "—"))
+                     (td ([class "text-end"]) ,(if latest-target (round 2 latest-target) "—"))
+                     (td ([class "text-end"]) ,(if delta-percentage (round 1 delta-percentage) "—")))))
 
      (a ([class "btn btn-primary mb-3"] [href "/measurement/new"]) "Ajouter un relevé")
      (table ([class "table table-striped"])
@@ -122,6 +131,16 @@
             [method "POST"])
            ,@(formlet-display (measurements-formlet)))))))
 
+(define (new-target-page)
+  (page-template
+   "Nouvelle cible"
+   `((h1 ([class "display-1 mb-3"]) "Nouvelle cible")
+     (div ([class "mb-3"] [style "max-width: 30em"])
+          (form
+           ([action "/target/create"]
+            [method "POST"])
+           ,@(formlet-display (targets-formlet)))))))
+
 (define (fallback-page request-code)
   (page-template
    (format "Réponse: ~a" request-code)
author	Marius Peter <dev@marius-peter.com>	2025-10-21 21:36:09 +0200
committer	Marius Peter <dev@marius-peter.com>	2025-10-21 21:36:09 +0200
commit	86b5343292e852155dab10fc8db39c2dd2b932eb (patch)
tree	be7da4f70ecf803aec3b3e3498d6e2ed6e98003f
parent	9bdb71dfc7d10b20bf8f78823194f4e114f8fa16 (diff)