starwisp.scm 66.3 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15
;; 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/>.

16 17 18
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; strings

19 20
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; fragments
Dave Griffiths's avatar
Dave Griffiths committed
21 22 23

(define-fragment-list

24 25 26
  (fragment
   "pf-timer"
   (linear-layout
27
    (make-id "") 'vertical fillwrap trans-col
28
    (list
29
     (mtitle "pf-details" "Pack: xxx Pup: xxx")))
30 31 32
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
33 34 35 36 37 38
     (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"))
                     )))
39 40 41 42 43 44 45
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


  (fragment
46
   "events"
47
   (linear-layout
48
    0 'vertical fillwrap trans-col
49
    (list
50
     (linear-layout
Dave Griffiths's avatar
Dave Griffiths committed
51
      (make-id "ev-pf") 'vertical fill pf-col
52
      (list
53 54
       (mtitle "ev-pf-text" "Pup Focal Events")
       (horiz
Dave Griffiths's avatar
Dave Griffiths committed
55 56 57 58
        (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")))))))
59
     (linear-layout
60
      (make-id "ev-pf") 'vertical fill gp-col
61
      (list
62 63
       (mtitle "text" "Group Events")
       (horiz
Dave Griffiths's avatar
Dave Griffiths committed
64 65
        (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"))))
66 67
        (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")))))))))
68 69 70
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
71
     (if (equal? (get-current 'observation "none") obs-pf)
72 73
         (list
          (update-widget 'text-view (get-id "ev-pf-text") 'show 0)
Dave Griffiths's avatar
Dave Griffiths committed
74 75 76 77
          (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))))
78 79 80 81
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))
82

83 84 85
  (fragment
   "pf-scan1"
   (linear-layout
86
    (make-id "") 'vertical fillwrap pf-col
87
    (list
Dave Griffiths's avatar
Dave Griffiths committed
88
     (build-grid-selector "pf-scan-nearest" "single" "<b>Nearest Neighbour Scan</b>: Closest Mongoose")
89
     (build-grid-selector "pf-scan-close" "toggle" "Mongooses within 2m")
90 91
     (mbutton "pf-scan-done" "Done"
              (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
92
                (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
Dave Griffiths's avatar
Dave Griffiths committed
93
                (entity-record-values!)
94
                (list (replace-fragment (get-id "pf-top") "pf-timer"))))))
95 96 97 98

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
99
     (entity-init! db "stream" "pup-focal-nearest" '())
Dave Griffiths's avatar
Dave Griffiths committed
100
     (entity-set-value! "scan-time" "varchar" (date-time->string (date-time)))
101
     (list
102 103
      (play-sound "ping")
      (vibrate 300)
104
      (populate-grid-selector
105
       "pf-scan-nearest" "single"
106
       (db-mongooses-by-pack-adults) #t
107
       (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
108
         (entity-set-value! "id-nearest" "varchar" (ktv-get individual "unique_id"))
109 110
         (list)))
      (populate-grid-selector
111
       "pf-scan-close" "toggle"
112
       (db-mongooses-by-pack-adults) #t
113
       (lambda (individuals)
Dave Griffiths's avatar
Dave Griffiths committed
114
         (entity-set-value! "id-list-close" "varchar" (assemble-array individuals))
115 116
         (list)))
      ))
117 118 119 120 121 122
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


123 124 125
  (fragment
   "ev-pupfeed"
   (linear-layout
126
    (make-id "") 'vertical fillwrap pf-col
127
    (list
128
     (mtitle "title" "Event: Pup is fed")
129
     (build-grid-selector "pf-pupfeed-who" "single" "Who fed the pup?")
Dave Griffiths's avatar
Dave Griffiths committed
130
     (spacer 20)
131
     (horiz
Dave Griffiths's avatar
Dave Griffiths committed
132
      (mtext "text" "Food size")
133 134 135
      (mspinner "pf-pupfeed-size" list-sizes
                (lambda (v)
                  (entity-set-value! "size" "varchar" (spinner-choice list-sizes v)) '())))
Dave Griffiths's avatar
Dave Griffiths committed
136 137
     (spacer 20)
     (horiz
138 139
      (mbutton "pf-pupfeed-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
140
                 (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
Dave Griffiths's avatar
Dave Griffiths committed
141
                 (entity-record-values!)
142 143 144
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-pupfeed-cancel" "Cancel"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
145
                 (list (replace-fragment (get-id "event-holder") "events")))))))
146 147 148 149

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
150
     (entity-init!  db "stream" "pup-focal-pupfeed" '())
151 152 153
     (list
      (populate-grid-selector
       "pf-pupfeed-who" "single"
154
       (db-mongooses-by-pack-adults) #t
155
       (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
156
         (entity-set-value! "id-who" "varchar" (ktv-get individual "unique_id"))
157 158 159 160 161 162 163
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

Dave Griffiths's avatar
Dave Griffiths committed
164 165 166
  (fragment
   "ev-pupfind"
   (linear-layout
167
    (make-id "") 'vertical fillwrap pf-col
Dave Griffiths's avatar
Dave Griffiths committed
168
    (list
169
     (mtitle "title" "Event: Pup found food")
Dave Griffiths's avatar
Dave Griffiths committed
170 171
     (horiz
      (mtext "text" "Food size")
172 173
      (mspinner "pf-pupfind-size" list-sizes
                (lambda (v) (entity-set-value! "size" "varchar" (spinner-choice list-sizes v)) '())))
Dave Griffiths's avatar
Dave Griffiths committed
174
     (spacer 20)
Dave Griffiths's avatar
Dave Griffiths committed
175
     (horiz
176 177
      (mbutton "pf-pupfind-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
178
                 (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
Dave Griffiths's avatar
Dave Griffiths committed
179
                 (entity-record-values!)
180 181 182
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-pupfind-cancel" "Cancel"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
183
                 (list (replace-fragment (get-id "event-holder") "events")))))))
Dave Griffiths's avatar
Dave Griffiths committed
184 185 186 187

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
188
     (entity-init! db "stream" "pup-focal-pupfind" '())
Dave Griffiths's avatar
Dave Griffiths committed
189 190 191 192 193 194 195 196 197 198 199
     (list
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


  (fragment
   "ev-pupcare"
   (linear-layout
200
    (make-id "") 'vertical fillwrap pf-col
Dave Griffiths's avatar
Dave Griffiths committed
201
    (list
202
     (mtitle "title" "Event: Pup is cared for")
Dave Griffiths's avatar
Dave Griffiths committed
203
     (build-grid-selector "pf-pupcare-who" "single" "Who cared for the pup?")
Dave Griffiths's avatar
Dave Griffiths committed
204
     (spacer 20)
Dave Griffiths's avatar
Dave Griffiths committed
205
     (horiz
Dave Griffiths's avatar
Dave Griffiths committed
206
      (mtext "text" "Type of care")
207
      (mspinner "pf-pupcare-type" list-pupcare-type
208
               (lambda (v)
209
                 (entity-set-value! "type" "varchar" (spinner-choice list-pupcare-type v)) '())))
Dave Griffiths's avatar
Dave Griffiths committed
210 211
     (spacer 20)
     (horiz
212 213
      (mbutton "pf-pupcare-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
214
                 (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
Dave Griffiths's avatar
Dave Griffiths committed
215
                 (entity-record-values!)
216 217 218
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-pupcare-cancel" "Cancel"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
219
                 (list (replace-fragment (get-id "event-holder") "events")))))))
Dave Griffiths's avatar
Dave Griffiths committed
220 221 222 223

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
224
     (entity-init! db "stream" "pup-focal-pupcare" '())
Dave Griffiths's avatar
Dave Griffiths committed
225 226 227
     (list
      (populate-grid-selector
       "pf-pupcare-who" "single"
228
       (db-mongooses-by-pack-adults) #t
Dave Griffiths's avatar
Dave Griffiths committed
229
       (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
230
         (entity-set-value! "id-who" "varchar" (ktv-get individual "unique_id"))
Dave Griffiths's avatar
Dave Griffiths committed
231 232 233 234 235 236 237 238 239 240
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "ev-pupaggr"
   (linear-layout
241
    (make-id "") 'vertical fillwrap pf-col
Dave Griffiths's avatar
Dave Griffiths committed
242
    (list
243
     (mtitle "title" "Event: Pup aggression")
Dave Griffiths's avatar
Dave Griffiths committed
244 245 246
     (build-grid-selector "pf-pupaggr-partner" "single" "Aggressive mongoose")

     (linear-layout
247
      (make-id "") 'horizontal (layout 'fill-parent 100 '1 'left 0) trans-col
Dave Griffiths's avatar
Dave Griffiths committed
248 249 250
      (list
       (vert
        (mtext "" "Fighting over")
251 252 253
        (mspinner "pf-pupaggr-over" list-aggression-over
                  (lambda (v)
                    (entity-set-value! "over" "varchar" (spinner-choice list-aggression-over v)) '())))
Dave Griffiths's avatar
Dave Griffiths committed
254 255
       (vert
        (mtext "" "Level")
256 257 258
        (mspinner "pf-pupaggr-level" list-aggression-level
                  (lambda (v)
                    (entity-set-value! "level" "varchar" (spinner-choice list-aggression-level v)) '())))
259 260 261 262 263

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

       ;(mtoggle-button "pf-pupaggr-in" "Initiate?"
       ;                (lambda (v)
Dave Griffiths's avatar
Dave Griffiths committed
264
       ;                  (entity-set-value! "initiate" "varchar" (if v "yes" "no")) '()))
265 266 267 268


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

Dave Griffiths's avatar
Dave Griffiths committed
269
     (spacer 20)
270 271 272
     (horiz
      (mbutton "pf-pupaggr-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
273
                 (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
Dave Griffiths's avatar
Dave Griffiths committed
274
                 (entity-record-values!)
275 276 277 278 279
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-pupaggr-cancel" "Cancel"
               (lambda ()
                 (list (replace-fragment (get-id "event-holder") "events")))))))

Dave Griffiths's avatar
Dave Griffiths committed
280 281 282 283

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
284
     (entity-init! db "stream" "pup-focal-pupaggr" '())
Dave Griffiths's avatar
Dave Griffiths committed
285 286 287
     (list
      (populate-grid-selector
       "pf-pupaggr-partner" "single"
288
       (db-mongooses-by-pack) #t
Dave Griffiths's avatar
Dave Griffiths committed
289
       (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
290
         (entity-set-value! "id-with" "varchar" (ktv-get individual "unique_id"))
Dave Griffiths's avatar
Dave Griffiths committed
291 292 293 294 295 296 297
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

298 299 300 301 302 303 304
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (fragment
   "ev-grpint"
   (linear-layout
    (make-id "") 'vertical fillwrap gp-col
    (list
305 306 307 308 309
     (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
310
        (mtext "text" "Outcome")
311 312 313
        (mspinner "gp-int-out" list-interaction-outcome
                  (lambda (v)
                    (entity-set-value! "outcome" "varchar" (spinner-choice list-interaction-outcome v)) '()))
314
        (mtext "text" "Duration")
315
        (edit-text (make-id "gp-int-dur") "" 30 "numeric" fillwrap
Dave Griffiths's avatar
Dave Griffiths committed
316
                   (lambda (v) (entity-set-value! "duration" "int" (string->number v)) '()))))
317 318 319 320
      (build-grid-selector "gp-int-pack" "single" "Other pack"))
     (linear-layout
      (make-id "") 'horizontal (layout 'fill-parent 80 '1 'left 0) trans-col
      (list
321 322
       (mbutton "pf-grpint-done" "Done"
                (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
323
                  (entity-record-values!)
324 325 326
                  (list (replace-fragment (get-id "event-holder") "events"))))
       (mbutton "pf-grpint-cancel" "Cancel"
                (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
327
                  (list (replace-fragment (get-id "event-holder") "events"))))))))
328

329

330 331 332
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
333
     (entity-init! db "stream" "group-interaction" '())
334 335 336 337 338
     (append
      (force-pause)
      (list
       (populate-grid-selector
        "gp-int-pack" "single"
339
        (db-all-sort-normal db "sync" "pack") #f
340
        (lambda (pack)
Dave Griffiths's avatar
Dave Griffiths committed
341
          (entity-set-value! "id-other-pack" "varchar" (ktv-get pack "unique_id"))
342 343 344
          (list)))
       (populate-grid-selector
        "gp-int-leader" "single"
345
        (db-mongooses-by-pack) #t
346
        (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
347
          (entity-set-value! "id-leader" "varchar" (ktv-get individual "unique_id"))
348 349
          (list)))
       )))
350 351 352 353 354 355 356 357 358 359 360 361 362
   (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")
363 364 365 366 367 368

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

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

375 376 377
     (horiz
      (mbutton "pf-grpalarm-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
378
                 (entity-record-values!)
379 380 381 382
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-grpalarm-cancel" "Cancel"
               (lambda ()
                 (list (replace-fragment (get-id "event-holder") "events")))))))
383 384 385 386

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
387
     (entity-init! db "stream" "group-alarm" '())
388 389 390 391 392
     (append
      (force-pause)
      (list
       (populate-grid-selector
        "gp-alarm-caller" "single"
393
        (db-mongooses-by-pack) #t
394
        (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
395
          (entity-set-value! "id-caller" "varchar" (ktv-get individual "unique_id"))
396
          (list))))
397 398 399 400 401 402 403 404 405 406 407
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "ev-grpmov"
   (linear-layout
    (make-id "") 'vertical fillwrap gp-col
    (list
Dave Griffiths's avatar
Dave Griffiths committed
408
     (build-grid-selector "gp-mov-leader" "single" "<b>Group movement</b>: Leader")
409
     (linear-layout
410
      (make-id "") 'horizontal (layout 'fill-parent 'wrap-content '1 'left 0) trans-col
411
      (list
Dave Griffiths's avatar
Dave Griffiths committed
412
       (medit-text "gp-mov-w" "Pack width" "numeric"
Dave Griffiths's avatar
Dave Griffiths committed
413
                   (lambda (v) (entity-set-value! "pack-width" "int" (string->number v)) '()))
Dave Griffiths's avatar
Dave Griffiths committed
414
       (medit-text "gp-mov-l" "Pack depth" "numeric"
Dave Griffiths's avatar
Dave Griffiths committed
415
                   (lambda (v) (entity-set-value! "pack-depth" "int" (string->number v)) '()))
Dave Griffiths's avatar
Dave Griffiths committed
416
       (medit-text "gp-mov-c" "How many?" "numeric"
Dave Griffiths's avatar
Dave Griffiths committed
417
                   (lambda (v) (entity-set-value! "pack-count" "int" (string->number v)) '()))))
418
     (linear-layout
419
      (make-id "") 'horizontal (layout 'fill-parent 'wrap-content '1 'left 0) trans-col
420
      (list
421 422
       (vert
        (mtext "" "Direction")
423 424
        (mspinner "gp-mov-dir" list-move-direction
                  (lambda (v) (entity-set-value! "direction" "varchar" (spinner-choice list-move-direction v))  '())))
425

Dave Griffiths's avatar
Dave Griffiths committed
426 427
       (vert
        (mtext "" "Where to")
428 429
        (mspinner "gp-mov-to" list-move-to
                  (lambda (v) (entity-set-value! "destination" "varchar" (spinner-choice list-move-to v))  '())))))
Dave Griffiths's avatar
Dave Griffiths committed
430 431 432 433 434

     (spacer 20)
     (horiz
      (mbutton "pf-grpmov-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
435
                 (entity-record-values!)
Dave Griffiths's avatar
Dave Griffiths committed
436 437 438 439
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-grpalarm-cancel" "Cancel"
               (lambda ()
                 (list (replace-fragment (get-id "event-holder") "events")))))))
440 441 442 443

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
444
     (entity-init! db "stream" "group-move" '())
445 446 447 448 449
     (append
      (force-pause)
      (list
       (populate-grid-selector
        "gp-mov-leader" "single"
450
        (db-mongooses-by-pack) #t
451
        (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
452
          (entity-set-value! "id-leader" "varchar" (ktv-get individual "unique_id"))
453 454
          (list)))
       )))
455 456 457 458 459
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

460 461 462 463 464 465
  (fragment
   "note"
   (linear-layout
    (make-id "") 'vertical fillwrap gp-col
    (list
     (mtitle "title" "Make a note")
466
     (edit-text (make-id "note-text") "" 30 "text" fillwrap
467
                (lambda (v)
Dave Griffiths's avatar
Dave Griffiths committed
468
                  (entity-set-value! "text" "varchar" v)
469 470 471 472
                  '()))
     (horiz
      (mbutton "note-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
473
                 (entity-record-values!)
474 475 476 477 478 479 480
                 (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))
481
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
482
     (entity-init!  db "stream" "note" '())
483 484 485 486
     (append
      (force-pause)
      (list
       (update-widget 'edit-text (get-id "note-text") 'request-focus 1))))
487 488 489 490
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))
491 492 493 494


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

495

Dave Griffiths's avatar
Dave Griffiths committed
496
  ;;(replace-fragment (get-id "gc-top") (cadr frag))))))))
497

Dave Griffiths's avatar
Dave Griffiths committed
498
  (fragment
499
   "gc-start"
500
   (linear-layout
501
    (make-id "") 'vertical fill gc-col
502 503
    (list
     (mtitle "title" "Start")
504 505
     (horiz
      (mtoggle-button "gc-start-main-obs" "I'm the main observer"
506 507
                      (lambda (v) (entity-update-single-value!
                                   (ktv "main-observer" "varchar" v)) '()))
508 509 510
      (vert
       (mtext "" "Code")
       (edit-text (make-id "gc-start-code") "" 30 "numeric" fillwrap
511 512
                  (lambda (v) (entity-update-values!
                               (ktv "group-comp-code" "varchar" v)) '()))))
Dave Griffiths's avatar
Dave Griffiths committed
513
     (build-grid-selector "gc-start-present" "toggle" "Who's present?")
Dave Griffiths's avatar
Dave Griffiths committed
514
     (next-button "gc-start-" "Go to weighing, have you finished here?" "gc-start" "gc-weights"
515
                  (lambda ()
516
                    (set-current! 'gc-not-present (invert-mongoose-selection (string-split-simple (entity-get-value "present") #\,)))
517 518
                    (entity-update-values!)
                    '()))
Dave Griffiths's avatar
Dave Griffiths committed
519
     ))
520 521 522 523

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
524
     ;; in case we come back from weights...
525
     (msg "frag start:" (get-current 'group-composition-id #f))
526 527
     (entity-init! db "stream" "group-composition"
                   (get-entity-by-unique db "stream" (get-current 'group-composition-id #f)))
Dave Griffiths's avatar
Dave Griffiths committed
528

529 530
     (append
      (list
Dave Griffiths's avatar
Dave Griffiths committed
531 532 533 534 535
       (update-widget 'edit-text (get-id "gc-start-code") 'text
                      (entity-get-value "group-comp-code"))
       (update-widget 'toggle-button (get-id "gc-start-main-obs") 'checked
                      (entity-get-value "main-observer"))

536 537 538 539 540 541
       (populate-grid-selector
        "gc-start-present" "toggle"
        (db-mongooses-by-pack) #f
        (lambda (individuals)
          (entity-set-value! "present" "varchar" (assemble-array individuals))
          (list))
542 543 544
        ;; 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)))))
545
      (update-grid-selector-checked "gc-start-present" "present"))
546
     )
547 548 549 550 551 552 553 554
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "gc-weights"
   (linear-layout
555
    (make-id "") 'vertical fill gc-col
556 557
    (list
     (mtitle "title" "Weights")
Dave Griffiths's avatar
Dave Griffiths committed
558
     (build-grid-selector "gc-weigh-choose" "single" "Choose mongoose")
Dave Griffiths's avatar
Dave Griffiths committed
559 560 561 562 563 564 565 566 567 568
     (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)))
                        '())))
Dave Griffiths's avatar
Dave Griffiths committed
569
     (next-button "gc-weigh-" "Go to pregnancies, have you finished here?" "gc-start" "gc-preg"
570 571 572 573 574
                  (lambda ()
                    ;; reset main entity
                    (entity-init! db "stream" "group-composition"
                                  (get-entity-by-unique db "stream" (get-current 'group-composition-id #f)))
                    '()))))
575 576 577 578

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
579
     (entity-init! db "stream" "weight" '())
580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604
     (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")))
605
              (update-widget 'toggle-button (get-id "gc-weigh-accurate") 'checked
606
                             (if (null? s) 0 (ktv-get (car s) "accurate"))))
607
             (update-selector-colours "gc-weigh-choose" "weight" (list "weight" "real" "!=" 0)))))))
Dave Griffiths's avatar
Dave Griffiths committed
608
      (update-grid-selector-enabled "gc-weigh-choose" (get-current 'gc-not-present '()))
609
      (update-selector-colours "gc-weigh-choose" "weight" (list "weight" "real" "!=" 0))))
610 611 612 613 614 615 616 617
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "gc-preg"
   (linear-layout
618
    (make-id "") 'vertical fill gc-col
619 620
    (list
     (mtitle "title" "Pregnant females")
Dave Griffiths's avatar
Dave Griffiths committed
621
     (build-grid-selector "gc-preg-choose" "toggle" "Choose")
Dave Griffiths's avatar
Dave Griffiths committed
622
     (next-button "gc-preg-" "Going to pup associations, have you finished here?" "gc-weights" "gc-pup-assoc"
Dave Griffiths's avatar
Dave Griffiths committed
623
                  (lambda () '()))))
624 625 626 627

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
628 629 630 631 632 633 634 635 636
     (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)))
       )
Dave Griffiths's avatar
Dave Griffiths committed
637
      (update-grid-selector-enabled "gc-preg-choose" (get-current 'gc-not-present '()))
638
      (update-grid-selector-checked "gc-preg-choose" "pregnant")))
639 640 641 642 643
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

644

645 646 647
  (fragment
   "gc-pup-assoc"
   (linear-layout
648
    (make-id "") 'vertical fill gc-col
649
    (list
Dave Griffiths's avatar
Dave Griffiths committed
650
     (mtitle "title" "Pup Associations")
651
     (build-grid-selector "gc-pup-choose" "single" "Choose pup")
Dave Griffiths's avatar
Dave Griffiths committed
652 653 654
     (horiz
      (vert
       (mtext "" "Strength")
655 656
       (mspinner "gc-pup-strength" list-strength
                 (lambda (v)
Dave Griffiths's avatar
Dave Griffiths committed
657
                   (msg "updating stren" (spinner-choice list-strength v))
658 659
                   (entity-update-single-value! (ktv "strength" "varchar" (spinner-choice list-strength v)))
                   '())))
Dave Griffiths's avatar
Dave Griffiths committed
660 661
      (vert
       (mtext "" "Accuracy")
662 663 664 665 666
       (mspinner "gc-pup-accuracy" list-strength
                 (lambda (v)
                   (msg "updating acc")
                   (entity-update-single-value! (ktv "accurate" "varchar" (spinner-choice list-strength v)))
                   '()))))
Dave Griffiths's avatar
Dave Griffiths committed
667
     (build-grid-selector "gc-pup-escort" "toggle" "Escort")
Dave Griffiths's avatar
Dave Griffiths committed
668
     (next-button "gc-pup-assoc-" "Going to oestrus, have you finished here?" "gc-preg" "gc-oestrus"
Dave Griffiths's avatar
Dave Griffiths committed
669 670 671 672 673
                  (lambda ()
                    ;; reset main entity
                    (entity-init! db "stream" "group-composition"
                                  (get-entity-by-unique db "stream" (get-current 'group-composition-id #f)))
                    '()))))
674 675 676 677

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
678 679 680
     (entity-init! db "stream" "pup-assoc" '())
     (append
      (list
681 682 683 684 685 686 687
       (populate-grid-selector
        "gc-pup-escort" "single"
        (db-mongooses-by-pack-adults) #t
        (lambda (escort-individual)
          ;; no pup yet...
          (list)))

688 689 690
       (populate-grid-selector
        "gc-pup-choose" "single"
        (db-mongooses-by-pack-pups) #f
691 692 693 694 695 696 697
        (lambda (pup-individual)
          (append
           (list
            (populate-grid-selector
             "gc-pup-escort" "single"
             (db-mongooses-by-pack-adults) #t
             (lambda (escort-individual)
Dave Griffiths's avatar
Dave Griffiths committed
698
               (msg "escort-individual clicked")
699 700 701 702 703 704 705 706 707 708 709
               (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"))
Dave Griffiths's avatar
Dave Griffiths committed
710 711
                                         (ktv "accurate" "varchar" "none")
                                         (ktv "strength" "varchar" "none")
712 713 714 715 716 717 718 719
                                         (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"))))

Dave Griffiths's avatar
Dave Griffiths committed
720 721 722 723 724 725
                  (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"))))
726 727

                 ))))
Dave Griffiths's avatar
Dave Griffiths committed
728 729 730 731 732 733
           (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")))
734
           (update-selector-colours3 "gc-pup-choose" "pup-assoc")
Dave Griffiths's avatar
Dave Griffiths committed
735
           (update-grid-selector-enabled "gc-pup-escort" (get-current 'gc-not-present '()))
736
           ))))
Dave Griffiths's avatar
Dave Griffiths committed
737 738
      (update-grid-selector-enabled "gc-pup-escort" (get-current 'gc-not-present '()))
      (update-grid-selector-enabled "gc-pup-choose" (get-current 'gc-not-present '()))
739 740
      (update-selector-colours3 "gc-pup-choose" "pup-assoc")
      ))
741

742 743 744 745 746
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

747 748


749 750 751
  (fragment
   "gc-oestrus"
   (linear-layout
752
    (make-id "") 'vertical fill gc-col
753
    (list
Dave Griffiths's avatar
Dave Griffiths committed
754
     (mtitle "" "Oestrus")
Dave Griffiths's avatar
Dave Griffiths committed
755 756 757 758
     (build-grid-selector "gc-oestrus-female" "single" "Choose female")
     (horiz
      (vert
       (mtext "" "Strength")
759
       (mspinner "gc-oestrus-strength" list-strength
Dave Griffiths's avatar
Dave Griffiths committed
760 761 762 763
                 (lambda (v)
                   (msg "updating stren" (spinner-choice list-strength v))
                   (entity-update-single-value! (ktv "strength" "varchar" (spinner-choice list-strength v)))
                   '())))
Dave Griffiths's avatar
Dave Griffiths committed
764 765
      (vert
       (mtext "" "Accuracy")
766
       (mspinner "gc-oestrus-accuracy" list-strength
Dave Griffiths's avatar
Dave Griffiths committed
767 768 769
                 (lambda (v)
                   (msg "updating acc")
                   (entity-update-single-value! (ktv "accurate" "varchar" (spinner-choice list-strength v)))
770 771 772 773 774 775 776 777
                   '())))

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

      )
778
     (build-grid-selector "gc-oestrus-guard" "toggle" "Choose mate guard")
Dave Griffiths's avatar
Dave Griffiths committed
779
     (next-button "gc-pup-oestrus-" "Going to babysitters, have you finished here?" "gc-pup-assoc" "gc-babysitting"
Dave Griffiths's avatar
Dave Griffiths committed
780 781 782 783 784
                  (lambda ()
                    ;; reset main entity
                    (entity-init! db "stream" "group-composition"
                                  (get-entity-by-unique db "stream" (get-current 'group-composition-id #f)))
                    '()))))
785 786 787
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
788 789 790
     (entity-init! db "stream" "mate-guard" '())
     (append
      (list
Dave Griffiths's avatar
Dave Griffiths committed
791 792 793 794 795 796 797
       (populate-grid-selector
        "gc-oestrus-guard" "single"
        (db-mongooses-by-pack-male) #t
        (lambda (escort-individual)
          ;; no pup yet...
          (list)))

798 799 800
       (populate-grid-selector
        "gc-oestrus-female" "single"
        (db-mongooses-by-pack-female) #f
Dave Griffiths's avatar
Dave Griffiths committed
801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818
        (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"))
Dave Griffiths's avatar
Dave Griffiths committed
819 820
                                         (ktv "accurate" "varchar" "none")
                                         (ktv "strength" "varchar" "none")
821
                                         (ktv "pester" "int" 0)
Dave Griffiths's avatar
Dave Griffiths committed
822 823 824 825 826 827
                                         (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")))
828 829
                   (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")))
Dave Griffiths's avatar
Dave Griffiths committed
830

Dave Griffiths's avatar
Dave Griffiths committed
831 832 833 834 835 836
                  (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"))))
Dave Griffiths's avatar
Dave Griffiths committed
837
                 ))))
Dave Griffiths's avatar
Dave Griffiths committed
838 839 840 841 842 843
           (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")))
Dave Griffiths's avatar
Dave Griffiths committed
844
           (update-selector-colours3 "gc-oestrus-female" "mate-guard")
Dave Griffiths's avatar
Dave Griffiths committed
845
           (update-grid-selector-enabled "gc-oestrus-guard" (get-current 'gc-not-present '()))
Dave Griffiths's avatar
Dave Griffiths committed
846
           ))))
Dave Griffiths's avatar
Dave Griffiths committed
847 848
      (update-grid-selector-enabled "gc-oestrus-guard" (get-current 'gc-not-present '()))
      (update-grid-selector-enabled "gc-oestrus-female" (get-current 'gc-not-present '()))
Dave Griffiths's avatar
Dave Griffiths committed
849 850
      (update-selector-colours3 "gc-oestrus-female" "mate-guard")
      ))
851

852 853 854 855 856 857 858 859
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "gc-babysitting"
   (linear-layout
860
    (make-id "") 'vertical fill gc-col
861
    (list
Dave Griffiths's avatar
Dave Griffiths committed
862
     (mtitle "" "Babysitters")
Dave Griffiths's avatar
Dave Griffiths committed
863 864 865 866
     (mtitle "title" "Seen")
     (build-grid-selector "gc-baby-seen" "toggle" "Choose")
     (mtitle "title" "By elimination")
     (build-grid-selector "gc-baby-byelim" "toggle" "Choose")
Dave Griffiths's avatar
Dave Griffiths committed
867
     (next-button "gc-pup-baby-" "Ending, have you finished here?" "gc-oestrus" "gc-end"
Dave Griffiths's avatar
Dave Griffiths committed
868
                  (lambda () '()))))
869 870 871
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
872 873 874 875 876 877 878 879 880
     (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)))
       )
Dave Griffiths's avatar
Dave Griffiths committed
881
      (update-grid-selector-enabled "gc-baby-seen" (get-current 'gc-not-present '()))
Dave Griffiths's avatar
Dave Griffiths committed
882 883 884 885 886 887 888 889 890
      (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)))
       )
Dave Griffiths's avatar
Dave Griffiths committed
891
      (update-grid-selector-enabled "gc-baby-byelim" (get-current 'gc-not-present '()))
Dave Griffiths's avatar
Dave Griffiths committed
892
      (update-grid-selector-checked "gc-baby-byelim" "baby-byelim")))
893 894 895 896
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))
897

898 899 900
  (fragment
   "gc-end"
   (linear-layout
901
    (make-id "") 'vertical fill gc-col
902
    (list
Dave Griffiths's avatar
Dave Griffiths committed
903
     (mtitle "" "Finish group composition")
Dave Griffiths's avatar