starwisp.scm

;; Starwisp Copyright (C) 2013 Dave Griffiths
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU Affero General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; strings

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; fragments

(define-fragment-list

  (fragment
   "pf-timer"
   (linear-layout
    (make-id "") 'vertical fillwrap trans-col
    (list
     (mtitle "pf-details" "Pack: xxx Pup: xxx")))
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
      (update-widget 'text-view (get-id "pf-details") 'text
                     (string-append
                      "Pack: " (ktv-get (get-current 'pack '()) "name") " "
                      "Pup: " (ktv-get (get-current 'individual '()) "name"))
                     )))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


  (fragment
   "events"
   (linear-layout
    0 'vertical fillwrap trans-col
    (list
     (linear-layout
      (make-id "ev-pf") 'vertical fill pf-col
      (list
       (mtitle "ev-pf-text" "Pup Focal Events")
       (horiz
        (mbutton2 "evb-pupfeed" "Pup Feed" (lambda () (list (replace-fragment (get-id "event-holder") "ev-pupfeed"))))
        (mbutton2 "evb-pupfind" "Pup Find" (lambda () (list (replace-fragment (get-id "event-holder") "ev-pupfind"))))
        (mbutton2 "evb-pupcare" "Pup Care" (lambda () (list (replace-fragment (get-id "event-holder") "ev-pupcare"))))
        (mbutton2 "evb-pupagg" "Pup Aggression" (lambda () (list (replace-fragment (get-id "event-holder") "ev-pupaggr")))))))
     (linear-layout
      (make-id "ev-pf") 'vertical fill gp-col
      (list
       (mtitle "text" "Group Events")
       (horiz
        (mbutton2 "evb-grpint" "Interaction" (lambda () (list (replace-fragment (get-id "event-holder") "ev-grpint"))))
        (mbutton2 "evb-grpalarm" "Alarm" (lambda () (list (replace-fragment (get-id "event-holder") "ev-grpalarm"))))
        (mbutton2 "evb-grpmov" "Movement" (lambda () (list (replace-fragment (get-id "event-holder") "ev-grpmov"))))
        (mbutton2 "evb-grpnote" "Note" (lambda () (list (replace-fragment (get-id "event-holder") "note")))))))))
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (if (equal? (get-current 'observation "none") obs-pf)
         (list
          (update-widget 'text-view (get-id "ev-pf-text") 'show 0)
          (update-widget 'linear-layout (get-id "ev-pf") 'show 0))
         (list
          (update-widget 'text-view (get-id "ev-pf-text") 'hide 0)
          (update-widget 'linear-layout (get-id "ev-pf") 'hide 0))))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "pf-scan1"
   (linear-layout
    (make-id "") 'vertical fillwrap pf-col
    (list
     (build-grid-selector "pf-scan-nearest" "single" "<b>Nearest Neighbour Scan</b>: Closest Mongoose")
     (build-grid-selector "pf-scan-close" "toggle" "Mongooses within 2m")
     (mbutton "pf-scan-done" "Done"
              (lambda ()
                (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
                (entity-record-values!)
                (list (replace-fragment (get-id "pf-top") "pf-timer"))))))

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (entity-init! db "stream" "pup-focal-nearest" '())
     (entity-set-value! "scan-time" "varchar" (date-time->string (date-time)))
     (list
      (play-sound "ping")
      (vibrate 300)
      (populate-grid-selector
       "pf-scan-nearest" "single"
       (db-mongooses-by-pack-adults) #t
       (lambda (individual)
         (entity-set-value! "id-nearest" "varchar" (ktv-get individual "unique_id"))
         (list)))
      (populate-grid-selector
       "pf-scan-close" "toggle"
       (db-mongooses-by-pack-adults) #t
       (lambda (individuals)
         (entity-set-value! "id-list-close" "varchar" (assemble-array individuals))
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


  (fragment
   "ev-pupfeed"
   (linear-layout
    (make-id "") 'vertical fillwrap pf-col
    (list
     (mtitle "title" "Event: Pup is fed")
     (build-grid-selector "pf-pupfeed-who" "single" "Who fed the pup?")
     (spacer 20)
     (horiz
      (mtext "text" "Food size")
      (mspinner "pf-pupfeed-size" list-sizes
                (lambda (v)
                  (entity-set-value! "size" "varchar" (spinner-choice list-sizes v)) '())))
     (spacer 20)
     (horiz
      (mbutton "pf-pupfeed-done" "Done"
               (lambda ()
                 (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
                 (entity-record-values!)
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-pupfeed-cancel" "Cancel"
               (lambda ()
                 (list (replace-fragment (get-id "event-holder") "events")))))))

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (entity-init!  db "stream" "pup-focal-pupfeed" '())
     (list
      (populate-grid-selector
       "pf-pupfeed-who" "single"
       (db-mongooses-by-pack-adults) #t
       (lambda (individual)
         (entity-set-value! "id-who" "varchar" (ktv-get individual "unique_id"))
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "ev-pupfind"
   (linear-layout
    (make-id "") 'vertical fillwrap pf-col
    (list
     (mtitle "title" "Event: Pup found food")
     (horiz
      (mtext "text" "Food size")
      (mspinner "pf-pupfind-size" list-sizes
                (lambda (v) (entity-set-value! "size" "varchar" (spinner-choice list-sizes v)) '())))
     (spacer 20)
     (horiz
      (mbutton "pf-pupfind-done" "Done"
               (lambda ()
                 (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
                 (entity-record-values!)
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-pupfind-cancel" "Cancel"
               (lambda ()
                 (list (replace-fragment (get-id "event-holder") "events")))))))

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (entity-init! db "stream" "pup-focal-pupfind" '())
     (list
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


  (fragment
   "ev-pupcare"
   (linear-layout
    (make-id "") 'vertical fillwrap pf-col
    (list
     (mtitle "title" "Event: Pup is cared for")
     (build-grid-selector "pf-pupcare-who" "single" "Who cared for the pup?")
     (spacer 20)
     (horiz
      (mtext "text" "Type of care")
      (mspinner "pf-pupcare-type" list-pupcare-type
               (lambda (v)
                 (entity-set-value! "type" "varchar" (spinner-choice list-pupcare-type v)) '())))
     (spacer 20)
     (horiz
      (mbutton "pf-pupcare-done" "Done"
               (lambda ()
                 (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
                 (entity-record-values!)
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-pupcare-cancel" "Cancel"
               (lambda ()
                 (list (replace-fragment (get-id "event-holder") "events")))))))

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (entity-init! db "stream" "pup-focal-pupcare" '())
     (list
      (populate-grid-selector
       "pf-pupcare-who" "single"
       (db-mongooses-by-pack-adults) #t
       (lambda (individual)
         (entity-set-value! "id-who" "varchar" (ktv-get individual "unique_id"))
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "ev-pupaggr"
   (linear-layout
    (make-id "") 'vertical fillwrap pf-col
    (list
     (mtitle "title" "Event: Pup aggression")
     (build-grid-selector "pf-pupaggr-partner" "single" "Aggressive mongoose")

     (linear-layout
      (make-id "") 'horizontal (layout 'fill-parent 100 '1 'left 0) trans-col
      (list
       (vert
        (mtext "" "Fighting over")
        (mspinner "pf-pupaggr-over" list-aggression-over
                  (lambda (v)
                    (entity-set-value! "over" "varchar" (spinner-choice list-aggression-over v)) '())))
       (vert
        (mtext "" "Level")
        (mspinner "pf-pupaggr-level" list-aggression-level
                  (lambda (v)
                    (entity-set-value! "level" "varchar" (spinner-choice list-aggression-level v)) '())))

       (tri-state "pf-pupaggr-in" "Initiate?" "initiate")

       ;(mtoggle-button "pf-pupaggr-in" "Initiate?"
       ;                (lambda (v)
       ;                  (entity-set-value! "initiate" "varchar" (if v "yes" "no")) '()))


       (tri-state "pf-pupaggr-win" "Win?" "win")))

     (spacer 20)
     (horiz
      (mbutton "pf-pupaggr-done" "Done"
               (lambda ()
                 (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
                 (entity-record-values!)
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-pupaggr-cancel" "Cancel"
               (lambda ()
                 (list (replace-fragment (get-id "event-holder") "events")))))))


   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (entity-init! db "stream" "pup-focal-pupaggr" '())
     (list
      (populate-grid-selector
       "pf-pupaggr-partner" "single"
       (db-mongooses-by-pack) #t
       (lambda (individual)
         (entity-set-value! "id-with" "varchar" (ktv-get individual "unique_id"))
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (fragment
   "ev-grpint"
   (linear-layout
    (make-id "") 'vertical fillwrap gp-col
    (list
     (build-grid-selector "gp-int-leader" "single" "<b>Inter-group interaction</b> Leader mongoose")
     (horiz
      (linear-layout
       (make-id "") 'vertical (layout 400 'fill-parent '1 'left 0) trans-col
       (list
        (mtext "text" "Outcome")
        (mspinner "gp-int-out" list-interaction-outcome
                  (lambda (v)
                    (entity-set-value! "outcome" "varchar" (spinner-choice list-interaction-outcome v)) '()))
        (mtext "text" "Duration")
        (edit-text (make-id "gp-int-dur") "" 30 "numeric" fillwrap
                   (lambda (v) (entity-set-value! "duration" "int" (string->number v)) '()))))
      (build-grid-selector "gp-int-pack" "single" "Other pack"))
     (linear-layout
      (make-id "") 'horizontal (layout 'fill-parent 80 '1 'left 0) trans-col
      (list
       (mbutton "pf-grpint-done" "Done"
                (lambda ()
                  (entity-record-values!)
                  (list (replace-fragment (get-id "event-holder") "events"))))
       (mbutton "pf-grpint-cancel" "Cancel"
                (lambda ()
                  (list (replace-fragment (get-id "event-holder") "events"))))))))


   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (entity-init! db "stream" "group-interaction" '())
     (append
      (force-pause)
      (list
       (populate-grid-selector
        "gp-int-pack" "single"
        (db-all-sort-normal db "sync" "pack") #f
        (lambda (pack)
          (entity-set-value! "id-other-pack" "varchar" (ktv-get pack "unique_id"))
          (list)))
       (populate-grid-selector
        "gp-int-leader" "single"
        (db-mongooses-by-pack) #t
        (lambda (individual)
          (entity-set-value! "id-leader" "varchar" (ktv-get individual "unique_id"))
          (list)))
       )))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


  (fragment
   "ev-grpalarm"
   (linear-layout
    (make-id "") 'vertical fillwrap gp-col
    (list
     (mtitle "title" "Event: Group alarm")
     (build-grid-selector "gp-alarm-caller" "single" "Alarm caller")

     (linear-layout
      (make-id "") 'horizontal fillwrap trans-col
      (list
       (vert
        (mtext "text" "Cause")
        (mspinner "gp-alarm-cause" list-alarm-cause
                  (lambda (v)
                    (entity-set-value! "cause" "varchar" (spinner-choice list-alarm-cause v)) '())))

       (tri-state "gp-alarm-join" "Did the others join in?" "others-join")))

     (horiz
      (mbutton "pf-grpalarm-done" "Done"
               (lambda ()
                 (entity-record-values!)
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-grpalarm-cancel" "Cancel"
               (lambda ()
                 (list (replace-fragment (get-id "event-holder") "events")))))))

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (entity-init! db "stream" "group-alarm" '())
     (append
      (force-pause)
      (list
       (populate-grid-selector
        "gp-alarm-caller" "single"
        (db-mongooses-by-pack) #t
        (lambda (individual)
          (entity-set-value! "id-caller" "varchar" (ktv-get individual "unique_id"))
          (list))))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "ev-grpmov"
   (linear-layout
    (make-id "") 'vertical fillwrap gp-col
    (list
     (build-grid-selector "gp-mov-leader" "single" "<b>Group movement</b>: Leader")
     (linear-layout
      (make-id "") 'horizontal (layout 'fill-parent 'wrap-content '1 'left 0) trans-col
      (list
       (medit-text "gp-mov-w" "Pack width" "numeric"
                   (lambda (v) (entity-set-value! "pack-width" "int" (string->number v)) '()))
       (medit-text "gp-mov-l" "Pack depth" "numeric"
                   (lambda (v) (entity-set-value! "pack-depth" "int" (string->number v)) '()))
       (medit-text "gp-mov-c" "How many?" "numeric"
                   (lambda (v) (entity-set-value! "pack-count" "int" (string->number v)) '()))))
     (linear-layout
      (make-id "") 'horizontal (layout 'fill-parent 'wrap-content '1 'left 0) trans-col
      (list
       (vert
        (mtext "" "Direction")
        (mspinner "gp-mov-dir" list-move-direction
                  (lambda (v) (entity-set-value! "direction" "varchar" (spinner-choice list-move-direction v))  '())))

       (vert
        (mtext "" "Where to")
        (mspinner "gp-mov-to" list-move-to
                  (lambda (v) (entity-set-value! "destination" "varchar" (spinner-choice list-move-to v))  '())))))

     (spacer 20)
     (horiz
      (mbutton "pf-grpmov-done" "Done"
               (lambda ()
                 (entity-record-values!)
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-grpalarm-cancel" "Cancel"
               (lambda ()
                 (list (replace-fragment (get-id "event-holder") "events")))))))

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (entity-init! db "stream" "group-move" '())
     (append
      (force-pause)
      (list
       (populate-grid-selector
        "gp-mov-leader" "single"
        (db-mongooses-by-pack) #t
        (lambda (individual)
          (entity-set-value! "id-leader" "varchar" (ktv-get individual "unique_id"))
          (list)))
       )))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "note"
   (linear-layout
    (make-id "") 'vertical fillwrap gp-col
    (list
     (mtitle "title" "Make a note")
     (edit-text (make-id "note-text") "" 30 "text" fillwrap
                (lambda (v)
                  (entity-set-value! "text" "varchar" v)
                  '()))
     (horiz
      (mbutton "note-done" "Done"
               (lambda ()
                 (entity-record-values!)
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "note-cancel" "Cancel"
               (lambda ()
                 (list (replace-fragment (get-id "event-holder") "events")))))))

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (entity-init!  db "stream" "note" '())
     (append
      (force-pause)
      (list
       (update-widget 'edit-text (get-id "note-text") 'request-focus 1))))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


  ;;(replace-fragment (get-id "gc-top") (cadr frag))))))))

  (fragment
   "gc-start"
   (linear-layout
    (make-id "") 'vertical fill gc-col
    (list
     (mtitle "title" "Start")
     (horiz
      (mtoggle-button "gc-start-main-obs" "I'm the main observer"
                      (lambda (v) (entity-update-single-value!
                                   (ktv "main-observer" "varchar" v)) '()))
      (vert
       (mtext "" "Code")
       (edit-text (make-id "gc-start-code") "" 30 "numeric" fillwrap
                  (lambda (v) (entity-update-values!
                               (ktv "group-comp-code" "varchar" v)) '()))))
     (build-grid-selector "gc-start-present" "toggle" "Who's present?")
     (next-button "gc-start-" "Go to weighing, have you finished here?" "gc-start" "gc-weights"
                  (lambda ()
                    (set-current! 'gc-not-present (invert-mongoose-selection (string-split-simple (entity-get-value "present") #\,)))
                    (entity-update-values!)
                    '()))
     ))

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     ;; in case we come back from weights...
     (msg "frag start:" (get-current 'group-composition-id #f))
     (entity-init! db "stream" "group-composition"
                   (get-entity-by-unique db "stream" (get-current 'group-composition-id #f)))

     (append
      (list
       (populate-grid-selector
        "gc-start-present" "toggle"
        (db-mongooses-by-pack) #f
        (lambda (individuals)
          (entity-set-value! "present" "varchar" (assemble-array individuals))
          (list))
        ;; need to invert, but not () if there are none set yet...
        (let ((r (get-current 'gc-not-present #f)))
          (if (not r) '() (invert-mongoose-selection r)))))
      (update-grid-selector-checked "gc-start-present" "present"))
     )
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "gc-weights"
   (linear-layout
    (make-id "") 'vertical fill gc-col
    (list
     (mtitle "title" "Weights")
     (build-grid-selector "gc-weigh-choose" "single" "Choose mongoose")
     (spacer 20)
     (horiz
      (edit-text (make-id "gc-weigh-weight") "" 30 "numeric" fillwrap
                 (lambda (v)
                   (entity-update-single-value! (ktv "weight" "real" (string->number v)))
                   '()))
      (mtoggle-button "gc-weigh-accurate" "Accurate?"
                      (lambda (v)
                        (entity-update-single-value! (ktv "accurate" "int" (if v 1 0)))
                        '())))
     (next-button "gc-weigh-" "Go to pregnancies, have you finished here?" "gc-start" "gc-preg"
                  (lambda ()
                    ;; reset main entity
                    (entity-init! db "stream" "group-composition"
                                  (get-entity-by-unique db "stream" (get-current 'group-composition-id #f)))
                    '()))))

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (entity-init! db "stream" "weight" '())
     (append
      (list
       (populate-grid-selector
        "gc-weigh-choose" "single"
        (db-mongooses-by-pack) #f
        (lambda (individual)
          ;; search for a weight for this individual...
          (let ((s (db-filter
                    db "stream" "weight"
                    (list (list "parent" "varchar" "=" (get-current 'group-composition-id 0))
                          (list "id-mongoose" "varchar" "=" (ktv-get individual "unique_id"))))))
            (if (null? s)
                ;; not there, make a new one
                (entity-init&save! db "stream" "weight"
                                   (list
                                    (ktv "name" "varchar" "")
                                    (ktv "weight" "real" 0)
                                    (ktv "accurate" "int" 0)
                                    (ktv "parent" "varchar" (get-current 'group-composition-id 0))
                                    (ktv "id-mongoose" "varchar" (ktv-get individual "unique_id"))))
                (entity-init! db "stream" "weight" (car s)))
            (append
             (list
              (update-widget 'edit-text (get-id "gc-weigh-weight") 'text
                             (if (null? s) "" (ktv-get (car s) "weight")))
              (update-widget 'toggle-button (get-id "gc-weigh-accurate") 'checked
                             (if (null? s) 0 (ktv-get (car s) "accurate"))))
             (update-selector-colours "gc-weigh-choose" "weight" (list "weight" "real" "!=" 0)))))))
      (update-grid-selector-enabled "gc-weigh-choose" (get-current 'gc-not-present '()))
      (update-selector-colours "gc-weigh-choose" "weight" (list "weight" "real" "!=" 0))))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "gc-preg"
   (linear-layout
    (make-id "") 'vertical fill gc-col
    (list
     (mtitle "title" "Pregnant females")
     (build-grid-selector "gc-preg-choose" "toggle" "Choose")
     (next-button "gc-preg-" "Going to pup associations, have you finished here?" "gc-weights" "gc-pup-assoc"
                  (lambda () '()))))

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (append
      (list
       (populate-grid-selector
        "gc-preg-choose" "toggle"
        (db-mongooses-by-pack-female) #f
        (lambda (individuals)
          (entity-update-single-value! (ktv "pregnant" "varchar" (assemble-array individuals)))
          (list)))
       )
      (update-grid-selector-enabled "gc-preg-choose" (get-current 'gc-not-present '()))
      (update-grid-selector-checked "gc-preg-choose" "pregnant")))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


  (fragment
   "gc-pup-assoc"
   (linear-layout
    (make-id "") 'vertical fill gc-col
    (list
     (mtitle "title" "Pup Associations")
     (build-grid-selector "gc-pup-choose" "single" "Choose pup")
     (horiz
      (vert
       (mtext "" "Strength")
       (mspinner "gc-pup-strength" list-strength
                 (lambda (v)
                   (msg "updating stren" (spinner-choice list-strength v))
                   (entity-update-single-value! (ktv "strength" "varchar" (spinner-choice list-strength v)))
                   '())))
      (vert
       (mtext "" "Accuracy")
       (mspinner "gc-pup-accuracy" list-strength
                 (lambda (v)
                   (msg "updating acc")
                   (entity-update-single-value! (ktv "accurate" "varchar" (spinner-choice list-strength v)))
                   '()))))
     (build-grid-selector "gc-pup-escort" "toggle" "Escort")
     (next-button "gc-pup-assoc-" "Going to oestrus, have you finished here?" "gc-preg" "gc-oestrus"
                  (lambda () '()))))

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (entity-init! db "stream" "pup-assoc" '())
     (append
      (list
       (populate-grid-selector
        "gc-pup-escort" "single"
        (db-mongooses-by-pack-adults) #t
        (lambda (escort-individual)
          ;; no pup yet...
          (list)))

       (populate-grid-selector
        "gc-pup-choose" "single"
        (db-mongooses-by-pack-pups) #f
        (lambda (pup-individual)
          (append
           (list
            (populate-grid-selector
             "gc-pup-escort" "single"
             (db-mongooses-by-pack-adults) #t
             (lambda (escort-individual)
               (msg "escort-individual clicked")
               (let ((s (db-filter
                         db "stream" "pup-assoc"
                         (list (list "parent" "varchar" "=" (get-current 'group-composition-id 0))
                               (list "id-escort" "varchar" "=" (ktv-get escort-individual "unique_id"))
                               (list "id-mongoose" "varchar" "=" (ktv-get pup-individual "unique_id"))))))
                 (if (null? s)
                     ;; not there, make a new one
                     (entity-init&save! db "stream" "pup-assoc"
                                        (list
                                         (ktv "name" "varchar" "")
                                         (ktv "id-escort" "varchar" (ktv-get escort-individual "unique_id"))
                                         (ktv "accurate" "varchar" "none")
                                         (ktv "strength" "varchar" "none")
                                         (ktv "parent" "varchar" (get-current 'group-composition-id 0))
                                         (ktv "id-mongoose" "varchar" (ktv-get pup-individual "unique_id"))))
                     (entity-init! db "stream" "pup-assoc" (car s)))
                 (append
                  (list
                   (update-widget 'spinner (get-id "gc-pup-strength") 'selection (spinner-index list-strength (entity-get-value "strength")))
                   (update-widget 'spinner (get-id "gc-pup-accuracy") 'selection (spinner-index list-strength (entity-get-value "accurate"))))

                  (update-selector-colours2
                   "gc-pup-escort" "pup-assoc"
                   (list
                    (list "id-mongoose" "varchar" "=" (ktv-get pup-individual "unique_id"))
                    (list "strength" "varchar" "!=" "none")
                    (list "accurate" "varchar" "!=" "none"))))

                 ))))
           (update-selector-colours2
            "gc-pup-escort" "pup-assoc"
            (list
             (list "id-mongoose" "varchar" "=" (ktv-get pup-individual "unique_id"))
             (list "strength" "varchar" "!=" "none")
             (list "accurate" "varchar" "!=" "none")))
           (update-selector-colours3 "gc-pup-choose" "pup-assoc")
           (update-grid-selector-enabled "gc-pup-escort" (get-current 'gc-not-present '()))
           ))))
      (update-grid-selector-enabled "gc-pup-escort" (get-current 'gc-not-present '()))
      (update-grid-selector-enabled "gc-pup-choose" (get-current 'gc-not-present '()))
      (update-selector-colours3 "gc-pup-choose" "pup-assoc")
      ))

   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))



  (fragment
   "gc-oestrus"
   (linear-layout
    (make-id "") 'vertical fill gc-col
    (list
     (mtitle "" "Oestrus")
     (build-grid-selector "gc-oestrus-female" "single" "Choose female")
     (horiz
      (vert
       (mtext "" "Strength")
       (mspinner "gc-oestrus-strength" list-strength
                 (lambda (v)
                   (msg "updating stren" (spinner-choice list-strength v))
                   (entity-update-single-value! (ktv "strength" "varchar" (spinner-choice list-strength v)))
                   '())))
      (vert
       (mtext "" "Accuracy")
       (mspinner "gc-oestrus-accuracy" list-strength
                 (lambda (v)
                   (msg "updating acc")
                   (entity-update-single-value! (ktv "accurate" "varchar" (spinner-choice list-strength v)))
                   '())))

      (mtoggle-button "gc-oestrus-pester" "Pestering?"
                      (lambda (v)
                        (entity-update-single-value! (ktv "pester" "int" (if v 1 0)))
                        '()))

      )
     (build-grid-selector "gc-oestrus-guard" "toggle" "Choose mate guard")
     (next-button "gc-pup-oestrus-" "Going to babysitters, have you finished here?" "gc-pup-assoc" "gc-babysitting"
                  (lambda () '()))))
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (entity-init! db "stream" "mate-guard" '())
     (append
      (list
       (populate-grid-selector
        "gc-oestrus-guard" "single"
        (db-mongooses-by-pack-male) #t
        (lambda (escort-individual)
          ;; no pup yet...
          (list)))

       (populate-grid-selector
        "gc-oestrus-female" "single"
        (db-mongooses-by-pack-female) #f
        (lambda (pup-individual)
          (append
           (list
            (populate-grid-selector
             "gc-oestrus-guard" "single"
             (db-mongooses-by-pack-adults) #t
             (lambda (escort-individual)
               (let ((s (db-filter
                         db "stream" "mate-guard"
                         (list (list "parent" "varchar" "=" (get-current 'group-composition-id 0))
                               (list "id-escort" "varchar" "=" (ktv-get escort-individual "unique_id"))
                               (list "id-mongoose" "varchar" "=" (ktv-get pup-individual "unique_id"))))))
                 (if (null? s)
                     ;; not there, make a new one
                     (entity-init&save! db "stream" "mate-guard"
                                        (list
                                         (ktv "name" "varchar" "")
                                         (ktv "id-escort" "varchar" (ktv-get escort-individual "unique_id"))
                                         (ktv "accurate" "varchar" "none")
                                         (ktv "strength" "varchar" "none")
                                         (ktv "pester" "int" 0)
                                         (ktv "parent" "varchar" (get-current 'group-composition-id 0))
                                         (ktv "id-mongoose" "varchar" (ktv-get pup-individual "unique_id"))))
                     (entity-init! db "stream" "mate-guard" (car s)))
                 (append
                  (list
                   (update-widget 'spinner (get-id "gc-oestrus-strength") 'selection (spinner-index list-strength (entity-get-value "strength")))
                   (update-widget 'spinner (get-id "gc-oestrus-accuracy") 'selection (spinner-index list-strength (entity-get-value "accurate")))
                   (update-widget 'toggle-button (get-id "gc-oestrus-pester") 'checked (entity-get-value "pester")))

                  (update-selector-colours2
                   "gc-oestrus-guard" "mate-guard"
                   (list
                    (list "id-mongoose" "varchar" "=" (ktv-get pup-individual "unique_id"))
                    (list "strength" "varchar" "!=" "none")
                    (list "accurate" "varchar" "!=" "none"))))
                 ))))
           (update-selector-colours2
            "gc-oestrus-guard" "mate-guard"
            (list
             (list "id-mongoose" "varchar" "=" (ktv-get pup-individual "unique_id"))
             (list "strength" "varchar" "!=" "none")
             (list "accurate" "varchar" "!=" "none")))
           (update-selector-colours3 "gc-oestrus-female" "mate-guard")
           (update-grid-selector-enabled "gc-oestrus-guard" (get-current 'gc-not-present '()))
           ))))
      (update-grid-selector-enabled "gc-oestrus-guard" (get-current 'gc-not-present '()))
      (update-grid-selector-enabled "gc-oestrus-female" (get-current 'gc-not-present '()))
      (update-selector-colours3 "gc-oestrus-female" "mate-guard")
      ))

   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "gc-babysitting"
   (linear-layout
    (make-id "") 'vertical fill gc-col
    (list
     (mtitle "" "Babysitters")
     (mtitle "title" "Seen")
     (build-grid-selector "gc-baby-seen" "toggle" "Choose")
     (mtitle "title" "By elimination")
     (build-grid-selector "gc-baby-byelim" "toggle" "Choose")
     (next-button "gc-pup-baby-" "Ending, have you finished here?" "gc-oestrus" "gc-end"
                  (lambda () '()))))
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (append
      (list
       (populate-grid-selector
        "gc-baby-seen" "toggle"
        (db-mongooses-by-pack-adults) #f
        (lambda (individuals)
          (entity-update-single-value! (ktv "baby-seen" "varchar" (assemble-array individuals)))
          (list)))
       )
      (update-grid-selector-enabled "gc-baby-seen" (get-current 'gc-not-present '()))
      (update-grid-selector-checked "gc-baby-seen" "baby-seen")
      (list
       (populate-grid-selector
        "gc-baby-byelim" "toggle"
        (db-mongooses-by-pack-adults) #f
        (lambda (individuals)
          (entity-update-single-value! (ktv "baby-byelim" "varchar" (assemble-array individuals)))
          (list)))
       )
      (update-grid-selector-enabled "gc-baby-byelim" (get-current 'gc-not-present '()))
      (update-grid-selector-checked "gc-baby-byelim" "baby-byelim")))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "gc-end"
   (linear-layout
    (make-id "") 'vertical fill gc-col
    (list
     (mtitle "" "Finish group composition")
     (next-button "gc-pup-baby-" "Ending, have you finished here?" "gc-babysitting" "gc-end"
                  (lambda ()
                    ;; clean up...
                    (get-current 'gc-not-present '())
                    (set-current! 'group-composition-id #f)
                    (list (finish-activity 0))))))
   (lambda (fragment arg)
     (activity-layout fragment))