starwisp.scm 64.9 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 531 532 533 534 535 536
     (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))
537 538 539
        ;; 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)))))
540
      (update-grid-selector-checked "gc-start-present" "present"))
541
     )
542 543 544 545 546 547 548 549
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

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

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

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

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
623 624 625 626 627 628 629 630 631
     (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
632
      (update-grid-selector-enabled "gc-preg-choose" (get-current 'gc-not-present '()))
633
      (update-grid-selector-checked "gc-preg-choose" "pregnant")))
634 635 636 637 638
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

639

640 641 642
  (fragment
   "gc-pup-assoc"
   (linear-layout
643
    (make-id "") 'vertical fill gc-col
644
    (list
Dave Griffiths's avatar
Dave Griffiths committed
645
     (mtitle "title" "Pup Associations")
646
     (build-grid-selector "gc-pup-choose" "single" "Choose pup")
Dave Griffiths's avatar
Dave Griffiths committed
647 648 649
     (horiz
      (vert
       (mtext "" "Strength")
650 651
       (mspinner "gc-pup-strength" list-strength
                 (lambda (v)
Dave Griffiths's avatar
Dave Griffiths committed
652
                   (msg "updating stren" (spinner-choice list-strength v))
653 654
                   (entity-update-single-value! (ktv "strength" "varchar" (spinner-choice list-strength v)))
                   '())))
Dave Griffiths's avatar
Dave Griffiths committed
655 656
      (vert
       (mtext "" "Accuracy")
657 658 659 660 661
       (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
662
     (build-grid-selector "gc-pup-escort" "toggle" "Escort")
Dave Griffiths's avatar
Dave Griffiths committed
663
     (next-button "gc-pup-assoc-" "Going to oestrus, have you finished here?" "gc-preg" "gc-oestrus"
Dave Griffiths's avatar
Dave Griffiths committed
664
                  (lambda () '()))))
665 666 667 668

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
669 670 671
     (entity-init! db "stream" "pup-assoc" '())
     (append
      (list
672 673 674 675 676 677 678
       (populate-grid-selector
        "gc-pup-escort" "single"
        (db-mongooses-by-pack-adults) #t
        (lambda (escort-individual)
          ;; no pup yet...
          (list)))

679 680 681
       (populate-grid-selector
        "gc-pup-choose" "single"
        (db-mongooses-by-pack-pups) #f
682 683 684 685 686 687 688
        (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
689
               (msg "escort-individual clicked")
690 691 692 693 694 695 696 697 698 699 700
               (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
701 702
                                         (ktv "accurate" "varchar" "none")
                                         (ktv "strength" "varchar" "none")
703 704 705 706 707 708 709 710
                                         (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
711 712 713 714 715 716
                  (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"))))
717 718

                 ))))
Dave Griffiths's avatar
Dave Griffiths committed
719 720 721 722 723 724
           (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")))
725
           (update-selector-colours3 "gc-pup-choose" "pup-assoc")
Dave Griffiths's avatar
Dave Griffiths committed
726
           (update-grid-selector-enabled "gc-pup-escort" (get-current 'gc-not-present '()))
727
           ))))
Dave Griffiths's avatar
Dave Griffiths committed
728 729
      (update-grid-selector-enabled "gc-pup-escort" (get-current 'gc-not-present '()))
      (update-grid-selector-enabled "gc-pup-choose" (get-current 'gc-not-present '()))
730 731
      (update-selector-colours3 "gc-pup-choose" "pup-assoc")
      ))
732

733 734 735 736 737
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

738 739


740 741 742
  (fragment
   "gc-oestrus"
   (linear-layout
743
    (make-id "") 'vertical fill gc-col
744
    (list
Dave Griffiths's avatar
Dave Griffiths committed
745
     (mtitle "" "Oestrus")
Dave Griffiths's avatar
Dave Griffiths committed
746 747 748 749
     (build-grid-selector "gc-oestrus-female" "single" "Choose female")
     (horiz
      (vert
       (mtext "" "Strength")
750
       (mspinner "gc-oestrus-strength" list-strength
Dave Griffiths's avatar
Dave Griffiths committed
751 752 753 754
                 (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
755 756
      (vert
       (mtext "" "Accuracy")
757
       (mspinner "gc-oestrus-accuracy" list-strength
Dave Griffiths's avatar
Dave Griffiths committed
758 759 760
                 (lambda (v)
                   (msg "updating acc")
                   (entity-update-single-value! (ktv "accurate" "varchar" (spinner-choice list-strength v)))
761 762 763 764 765 766 767 768
                   '())))

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

      )
769
     (build-grid-selector "gc-oestrus-guard" "toggle" "Choose mate guard")
Dave Griffiths's avatar
Dave Griffiths committed
770
     (next-button "gc-pup-oestrus-" "Going to babysitters, have you finished here?" "gc-pup-assoc" "gc-babysitting"
Dave Griffiths's avatar
Dave Griffiths committed
771
                  (lambda () '()))))
772 773 774
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
775 776 777
     (entity-init! db "stream" "mate-guard" '())
     (append
      (list
Dave Griffiths's avatar
Dave Griffiths committed
778 779 780 781 782 783 784
       (populate-grid-selector
        "gc-oestrus-guard" "single"
        (db-mongooses-by-pack-male) #t
        (lambda (escort-individual)
          ;; no pup yet...
          (list)))

785 786 787
       (populate-grid-selector
        "gc-oestrus-female" "single"
        (db-mongooses-by-pack-female) #f
Dave Griffiths's avatar
Dave Griffiths committed
788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805
        (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
806 807
                                         (ktv "accurate" "varchar" "none")
                                         (ktv "strength" "varchar" "none")
808
                                         (ktv "pester" "int" 0)
Dave Griffiths's avatar
Dave Griffiths committed
809 810 811 812 813 814
                                         (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")))
815 816
                   (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
817

Dave Griffiths's avatar
Dave Griffiths committed
818 819 820 821 822 823
                  (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
824
                 ))))
Dave Griffiths's avatar
Dave Griffiths committed
825 826 827 828 829 830
           (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
831
           (update-selector-colours3 "gc-oestrus-female" "mate-guard")
Dave Griffiths's avatar
Dave Griffiths committed
832
           (update-grid-selector-enabled "gc-oestrus-guard" (get-current 'gc-not-present '()))
Dave Griffiths's avatar
Dave Griffiths committed
833
           ))))
Dave Griffiths's avatar
Dave Griffiths committed
834 835
      (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
836 837
      (update-selector-colours3 "gc-oestrus-female" "mate-guard")
      ))
838

839 840 841 842 843 844 845 846
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "gc-babysitting"
   (linear-layout
847
    (make-id "") 'vertical fill gc-col
848
    (list
Dave Griffiths's avatar
Dave Griffiths committed
849
     (mtitle "" "Babysitters")
Dave Griffiths's avatar
Dave Griffiths committed
850 851 852 853
     (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
854
     (next-button "gc-pup-baby-" "Ending, have you finished here?" "gc-oestrus" "gc-end"
Dave Griffiths's avatar
Dave Griffiths committed
855
                  (lambda () '()))))
856 857 858
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
859 860 861 862 863 864 865 866 867
     (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
868
      (update-grid-selector-enabled "gc-baby-seen" (get-current 'gc-not-present '()))
Dave Griffiths's avatar
Dave Griffiths committed
869 870 871 872 873 874 875 876 877
      (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
878
      (update-grid-selector-enabled "gc-baby-byelim" (get-current 'gc-not-present '()))
Dave Griffiths's avatar
Dave Griffiths committed
879
      (update-grid-selector-checked "gc-baby-byelim" "baby-byelim")))
880 881 882 883
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))
884

885 886 887
  (fragment
   "gc-end"
   (linear-layout
888
    (make-id "") 'vertical fill gc-col
889
    (list
Dave Griffiths's avatar
Dave Griffiths committed
890
     (mtitle "" "Finish group composition")
Dave Griffiths's avatar
Dave Griffiths committed
891
     (next-button "gc-pup-baby-" "Ending, have you finished here?" "gc-babysitting" "gc-end"
892 893 894 895 896
                  (lambda ()
                    ;; clean up...
                    (get-current 'gc-not-present '())
                    (set-current! 'group-composition-id #f)
                    (list (finish-activity 0))))))
Dave Griffiths's avatar
Dave Griffiths committed
897 898
   (lambda (fragment arg)
     (activity-layout fragment))