starwisp.scm 74.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
19
20
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; strings

(define obs-gc "Group Composition")
(define obs-pf "Pup Focal")
21
22
(define obs-gp "Group Events")

23
24
25
26
27
28
29
30
31
32
33
34
(define entity-types
  (list
   "pup-focal"
   "pup-focal-nearest"
   "pup-focal-pupfeed"
   "pup-focal-pupfind"
   "pup-focal-pupcare"
   "pup-focal-pupaggr"
   "group-interaction"
   "group-alarm"
   "group-move"))

35
36
37
38
39
40
41
42
(define pup-focal-export
  (list
   "pup-focal-nearest"
   "pup-focal-pupfeed"
   "pup-focal-pupfind"
   "pup-focal-pupcare"
   "pup-focal-pupaggr"))

43
(define list-sizes (list "Small" "Medium" "Large"))
44

45
46
;; colours

47
48
49
50
51
52
53
54
55
56
57
58
(define pf-col (list 255 204 51 255))
(define gp-col (list 255 102 0 255))
(define gc-col (list 164 82 9 255))

(define pf-bgcol (list 255 204 51 127))
(define gp-bgcol (list 255 102 0 127))
(define gc-bgcol (list 164 82 9 127))

;(define pf-col (list  22  19 178  127))
;(define gp-col (list 255  97   0  127))
;(define gc-col (list 255 236   0  127))

59
60
61


(define trans-col (list 0 0 0 0))
62
63
64
65
66
67
68
69
70
71
72
73
74
75

(define (get-fragment-index name frag)
  (define (_ i l)
    (cond
     ((null? l) 0)
     ((equal? name (cadr (car l))) i)
     (else (_ (+ i 1) (cdr l)))))
  (_ 0 frag))

(define gc-fragments
  (list
   (list "Start" "gc-start")
   (list "Weights" "gc-weights")
   (list "Pregnant" "gc-preg")
76
   (list "Pup assoc" "gc-pup-assoc")
77
78
79
80
   (list "Oestrus" "gc-oestrus")
   (list "Babysit" "gc-babysitting")
   (list "End" "gc-end")))

81
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Dave Griffiths's avatar
Dave Griffiths committed
82
;; persistent database
83

84
(define db "/sdcard/mongoose/local-mongoose.db")
85
(define main-db "/sdcard/mongoose/mongoose.db")
86

87
88
89
90
91
92
93
94
95
96
97
98
99
(define (setup-database!)
  (msg "setting up database")
  (db-close db) ;; close just in case (sorts out db file delete while running problem)
  (db-open db)
  (msg "setting up tables")
  (setup db "local")
  (setup db "sync")
  (setup db "stream")
  (msg (db-status db))
  (insert-entity-if-not-exists
   db "local" "app-settings" "null" 1
   (list
    (ktv "user-id" "varchar" "No name yet...")))
100
  (msg (db-all-sort-normal db "local" "app-settings")))
Dave Griffiths's avatar
Dave Griffiths committed
101

Dave Griffiths's avatar
Dave Griffiths committed
102
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
103
;; user interface abstraction
Dave Griffiths's avatar
Dave Griffiths committed
104

Dave Griffiths's avatar
Dave Griffiths committed
105
(define (mbutton id title fn)
106
  (button (make-id id) title 20 (layout 'fill-parent 'wrap-content 1 'centre 5) fn))
Dave Griffiths's avatar
Dave Griffiths committed
107

108
(define (mbutton2 id title fn)
109
  (button (make-id id) title 20 (layout 150 100 1 'centre 5) fn))
110

Dave Griffiths's avatar
Dave Griffiths committed
111
112
113
(define (mbutton-small id title fn)
  (button (make-id id) title 30 (layout 'wrap-content 'wrap-content -1 'right 5) fn))

114
(define (mtoggle-button id title fn)
115
  (toggle-button (make-id id) title 20 (layout 'fill-parent 'wrap-content 1 'centre 5) "fancy" fn))
116

117
(define (mtoggle-button-yes id title fn)
118
  (toggle-button (make-id id) title 20 (layout 49 43 1 'centre 0) "yes" fn))
119
120

(define (mtoggle-button-maybe id title fn)
121
  (toggle-button (make-id id) title 20 (layout  49 43 1 'centre 0) "maybe" fn))
122
123

(define (mtoggle-button-no id title fn)
124
  (toggle-button (make-id id) title 20 (layout  49 43 1 'centre 0) "no" fn))
125

126
(define (mtoggle-button2 id title fn)
127
  (toggle-button (make-id id) title 20 (layout 150 100 1 'centre 5) "plain" fn))
128

Dave Griffiths's avatar
Dave Griffiths committed
129
(define (mtext id text)
130
  (text-view (make-id id) text 20 fillwrap))
131

132
(define (mtitle id text)
133
  (text-view (make-id id) text 40 fillwrap))
134

135
136
(define (medit-text id text type fn)
  (vert
137
   (mtext (string-append id "-title") text)
138
   (edit-text (make-id id) "" 20 type fillwrap fn)))
139

Dave Griffiths's avatar
Dave Griffiths committed
140
141
142
(define (medit-text-value id text value type fn)
  (vert
   (mtext (string-append id "-title") text)
143
   (edit-text (make-id id) value 20 type fillwrap fn)))
Dave Griffiths's avatar
Dave Griffiths committed
144

145
146
147
148
149
150
(define (mclear-toggles id-list)
  (map
   (lambda (id)
     (update-widget 'toggle-button (get-id id) 'checked 0))
   id-list))

151
152
153
154
155
156
157
(define (mclear-toggles-not-me me id-list)
  (foldl
   (lambda (id r)
     (if (equal? me id)
         r (cons (update-widget 'toggle-button (get-id id) 'checked 0) r)))
   '() id-list))

158
159
160
161
162
163
164
165
166
167
(define (xwise n l)
  (define (_ c l)
    (cond
      ((null? l) (if (null? c) '() (list c)))
      ((eqv? (length c) (- n 1))
       (cons (append c (list (car l))) (_ '() (cdr l))))
      (else
       (_ (append c (list (car l))) (cdr l)))))
  (_ '() l))

168
169
;;;;

170
(define (build-grid-selector name type title)
171
172
173
174
175
176
177
178
179
180
  (linear-layout
   0 'vertical
   (layout 'fill-parent 'wrap-content 1 'left 0)
   (list 0 0 0 0)
   (list
    (mtext "title" title)
    (linear-layout
     0 'horizontal
     (layout 'fill-parent 'wrap-content 1 'left 2) trans-col
     (list
181
      (image-view (make-id "im") "arrow_left" (layout 200 'fill-parent 1 'left 0))
182
183
      (scroll-view
       (make-id "scroller")
184
       (layout 'wrap-content 'wrap-content 1 'left 5)
185
186
187
       (list
        (linear-layout
         (make-id name) 'horizontal
188
         (layout 'wrap-content 'wrap-content 1 'centre 5) trans-col
189
         (list
190
          (button-grid (make-id name) type 3 20 (layout 100 60 1 'left 5)
191
                       (list) (lambda (v) '()))))))
192
      (image-view (make-id "im") "arrow_right" (layout 200 'fill-parent 1 'right 0)))))))
193

194
;; assumes grid selectors on mongeese only
195
;; assumes order of ktv elements?
196
197
198
(define (fast-get-name item)
  (list-ref (list-ref item 1) 2))

199
200
201
(define (fast-get-id item)
  (list-ref (list-ref item 0) 2))

202
203
204
205
(define (build-button-items name items unknown)
  (append
   (map
    (lambda (item)
206
207
      (list (make-id (string-append name (fast-get-id item)))
            item (fast-get-name item)))
208
209
210
211
212
213
214
215
216
    items)
   (if unknown
       (list
        (list (make-id (string-append name "-unknown"))
              (list (ktv "name" "varchar" "Unknown")
                    (ktv "unique_id" "varchar" "Unknown"))
              "???"))
       '())))

217
(define (populate-grid-selector name type items unknown fn . args)
218
  (let ((id->items (build-button-items name items unknown))
219
220
221
222
223
        (selected-set (if (null? args)
                          '()
                          (map
                           (lambda (uid)
                             (get-id (string-append name uid))) (car args)))))
224
    (let ((r (update-widget
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
              'button-grid (get-id name) 'grid-buttons
              (list
               type 3 20 (layout 80 50 1 'left 2)
               (map
                (lambda (ii)
                  (list (car ii) (caddr ii)))
                id->items)
               (lambda (v state)
                 (cond
                  ((equal? type "toggle")
                   ;; update list of selected items
                   (if state
                       (set! selected-set (set-add v selected-set))
                       (set! selected-set (set-remove v selected-set)))
                   ;; find all items currently selected
                   (fn (map
                        (lambda (v)
                          (cadr (findv v id->items)))
                        selected-set)))
                  (else
                   ;;(msg (findv v id->items))
                   (fn (cadr (findv v id->items))))))))))
247
248
      r)))

249
250
251
252
253
254
255
256
257
258
259
260
261
262
263

(define (update-grid-selector-colours id item-id items)
  (map
   (lambda (item)
     (update-widget 'button (get-id (string-append id (ktv-get item item-id)))
                    'background-colour (list 0 100 0 155)))
   items))

(define (update-grid-selector-enabled id items)
  (map
   (lambda (item)
     (update-widget 'button (get-id (string-append id item))
                    'set-enabled 0))
   items))

264
265
(define (update-grid-selector-checked id items-id)
  (let ((items-str (entity-get-value items-id)))
266
    (msg "selector-checked for" id items-id items-str)
267
268
269
270
271
272
    (if items-str
        (map
         (lambda (item)
           (update-widget 'toggle-button (get-id (string-append id item)) 'checked 1))
         (string-split-simple items-str #\,))
        '())))
273

274
(define (db-mongooses-by-pack)
275
  (db-all-where
276
277
   db "sync" "mongoose"
   (ktv "pack-id" "varchar" (ktv-get (get-current 'pack '()) "unique_id"))))
278

279
280
281
282
283
284
(define (db-mongooses-by-pack-ignore-delete)
  (db-all-where-ignore-delete
   db "sync" "mongoose"
   (ktv "pack-id" "varchar" (ktv-get (get-current 'pack '()) "unique_id"))))


285
(define (db-mongooses-by-pack-male)
286
  (db-all-where2or
287
288
   db "sync" "mongoose"
   (ktv "pack-id" "varchar" (ktv-get (get-current 'pack '()) "unique_id"))
289
   (ktv "gender" "varchar" "Male") "Unknown"))
290
291

(define (db-mongooses-by-pack-female)
292
  (db-all-where2or
293
294
   db "sync" "mongoose"
   (ktv "pack-id" "varchar" (ktv-get (get-current 'pack '()) "unique_id"))
295
   (ktv "gender" "varchar" "Female") "Unknown"))
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311


;; (y m d h m s)
(define (date-minus-months d ms)
  (let ((year (list-ref d 0))
        (month (- (list-ref d 1) 1)))
    (let ((new-month (- month ms)))
      (list
       (if (< new-month 0) (- year 1) year)
       (+ (if (< new-month 0) (+ new-month 12) new-month) 1)
       (list-ref d 2)
       (list-ref d 3)
       (list-ref d 4)
       (list-ref d 5)))))

(define (db-mongooses-by-pack-pups)
Dave Griffiths's avatar
Dave Griffiths committed
312
  (db-all-newer
313
314
315
316
   db "sync" "mongoose"
   (ktv "pack-id" "varchar" (ktv-get (get-current 'pack '()) "unique_id"))
   (ktv "dob" "varchar" (date->string (date-minus-months (date-time) 6)))))

317
318
319
320
321
322
(define (db-mongooses-by-pack-adults)
  (db-all-older
   db "sync" "mongoose"
   (ktv "pack-id" "varchar" (ktv-get (get-current 'pack '()) "unique_id"))
   (ktv "dob" "varchar" (date->string (date-minus-months (date-time) 6)))))

323
324
325
326
327
328
329
330
331
332
333
334
335
336


(define (tri-state id text key)
  (linear-layout
   (make-id "") 'vertical (layout 'fill-parent 'wrap-content '1 'centre 0) trans-col
   (list
    (linear-layout
     (make-id "") 'horizontal (layout 'wrap-content 'wrap-parent '1 'centre 0) trans-col
     (list
      (mtoggle-button-yes
       (string-append id "-y") ""
       (lambda (v)
         (cond
          (v
Dave Griffiths's avatar
Dave Griffiths committed
337
           (entity-set-value! key "varchar" "yes")
338
339
340
341
342
343
344
345
346
347
348
349
           (list
            (update-widget 'toggle-button (get-id (string-append id "-n")) 'checked 0)
            (update-widget 'toggle-button (get-id (string-append id "-m")) 'checked 0)))
               (else
                (list
                 (update-widget 'toggle-button (get-id (string-append id "-y")) 'checked 1))))
              ))
      (mtoggle-button-maybe
       (string-append id "-m")  ""
       (lambda (v)
         (cond
          (v
Dave Griffiths's avatar
Dave Griffiths committed
350
           (entity-set-value! key "varchar" "maybe")
351
352
353
354
355
356
357
358
359
360
361
362
363
           (list
            (update-widget 'toggle-button (get-id (string-append id "-y")) 'checked 0)
            (update-widget 'toggle-button (get-id (string-append id "-n")) 'checked 0)))
          (else
           (list
            (update-widget 'toggle-button (get-id (string-append id "-m")) 'checked 1))))
         ))

      (mtoggle-button-no
       (string-append id "-n") ""
       (lambda (v)
         (cond
          (v
Dave Griffiths's avatar
Dave Griffiths committed
364
           (entity-set-value! key "varchar" "no")
365
366
367
368
369
370
371
372
373
374
           (list
            (update-widget 'toggle-button (get-id (string-append id "-y")) 'checked 0)
            (update-widget 'toggle-button (get-id (string-append id "-m")) 'checked 0)))
          (else
           (list
            (update-widget 'toggle-button (get-id (string-append id "-n")) 'checked 1))))
         ))))

    (text-view 0 text 30 (layout 'wrap-content 'wrap-parent '1 'centre 0)))))

Dave Griffiths's avatar
Dave Griffiths committed
375
376
377
378
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; review

(define (review-build-contents uid entity)
Dave Griffiths's avatar
Dave Griffiths committed
379
  (msg "review-build-contents")
Dave Griffiths's avatar
Dave Griffiths committed
380
  (append
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
   (foldl
    (lambda (ktv r)
      (append
       r (cond
          ((or (equal? (ktv-key ktv) "unique_id")
               (equal? (ktv-key ktv) "deleted")) '())
          ((equal? (ktv-type ktv) "varchar")
           (list (medit-text-value (string-append uid (ktv-key ktv))
                                   (ktv-key ktv)
                                   (ktv-value ktv) "normal"
                                   (lambda (v)
                                     (entity-set-value! (ktv-key ktv) (ktv-type ktv) v) '()))))
          ((equal? (ktv-type ktv) "int")
           (list (medit-text-value (string-append uid (ktv-key ktv))
                                   (ktv-key ktv)
                                   (number->string (ktv-value ktv)) "numeric"
                                   (lambda (v)
                                     (entity-set-value! (ktv-key ktv) (ktv-type ktv) v) '()))))
          ((equal? (ktv-type ktv) "real")
           (list (medit-text-value (string-append uid (ktv-key ktv))
                                   (ktv-key ktv)
                                   (number->string (ktv-value ktv)) "numeric"
                                   (lambda (v)
                                     (entity-set-value! (ktv-key ktv) (ktv-type ktv) v) '()))))
          (else (mtext "" (string-append (ktv-type ktv) " not handled")) '()))))
    '()
Dave Griffiths's avatar
Dave Griffiths committed
407
408
    entity)
   (list
Dave Griffiths's avatar
Dave Griffiths committed
409
410
    (horiz
     (mbutton "review-item-cancel" "Cancel" (lambda () (list (finish-activity 0))))
411
412
413
414
     (mbutton (string-append uid "-save") "Save"
              (lambda ()
                (entity-update-values!)
                (list (finish-activity 0))))))))
Dave Griffiths's avatar
Dave Griffiths committed
415
416
417
418
419
420
421
422
423
424
425

(define (review-item-build)
  (let ((uid (entity-get-value "unique_id")))
    (msg "review-item-build" uid)
    (list
     (update-widget
      'linear-layout
      (get-id "review-item-container")
      'contents
      (review-build-contents
       uid (get-current 'entity-values '()))))))
Dave Griffiths's avatar
Dave Griffiths committed
426
427
428
429
430
431
432
433
434
435
436

(define (review-update-list)
  (list
   (update-widget
    'linear-layout (get-id "review-list") 'contents
    (map
     (lambda (dirty-entity)
       ;; consists of ((type,uid,dirty,version) (ktvlist))
       (let* ((data (car dirty-entity))
              (entity (cadr dirty-entity))
              (time (ktv-get entity "time"))
Dave Griffiths's avatar
Dave Griffiths committed
437
              (type (list-ref data 0))
Dave Griffiths's avatar
Dave Griffiths committed
438
              (uid (list-ref data 1)))
Dave Griffiths's avatar
Dave Griffiths committed
439
440
441
442
443
444
         (mbutton
          (string-append "review-" uid)
          (string-append type (if time (string-append "-" time) ""))
          (lambda ()
            (entity-init! db "stream" type (get-entity-by-unique db "stream" uid))
            (list (start-activity "review-item" 0 ""))))))
Dave Griffiths's avatar
Dave Griffiths committed
445
446
     (dirty-entities-for-review db "stream")))))

447
448
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
Dave Griffiths's avatar
Dave Griffiths committed
449

450
451
452
453
(define (debug! txt)
  (set-current! 'debug-text (string-append txt "\n" (get-current 'debug-text ""))))

(define (update-debug)
454
455
456
  (update-widget 'debug-text-view (get-id "sync-debug") 'text
                 (get-current 'debug-text "")))

457
(define (debug-timer-cb)
Dave Griffiths's avatar
Dave Griffiths committed
458
459
460
461
462
463
464
465
466
467
468
469
470
  (append
   (cond
    ((get-current 'sync-on #f)
     (set-current! 'upload 0)
     (set-current! 'download 0)
     (connect-to-net
      (lambda ()
        (append
         (list (toast "sync-cb"))
         (upload-dirty db)
         (suck-new db "sync")))))
    (else '()))
   (list
471
    (delayed "debug-timer" (+ 10000 (random 5000)) debug-timer-cb)
Dave Griffiths's avatar
Dave Griffiths committed
472
    (update-debug))))
473

474

475
476
(define pf-length 20) ;; minutes...

477
478
479
480
481
482
483
(define (timer-cb)
  (set-current!
   'timer-seconds
   (- (get-current 'timer-seconds 59) 1))
  (append
   (cond
    ((< (get-current 'timer-seconds 59) 0)
484
     (set-current! 'timer-minutes (- (get-current 'timer-minutes pf-length) 1))
485
     (set-current! 'timer-seconds 59)
486
487
488
489
490
491
492
493
494
495
496
497
498
499
     (cond ((< (get-current 'timer-minutes pf-length) 1)
            (list
             (alert-dialog
              "pup-focal-end"
              "Pup focal time is up, have you finished?"
              (lambda (v)
                (cond
                 ((eqv? v 1)
                  (list (finish-activity 1)))
                 (else
                  (set-current! 'timer-minutes 1)
                  (list)))))))
           (else
            (list (replace-fragment (get-id "pf-top") "pf-scan1")))))
500
501
502
503
504
    (else '()))
   (list
    (delayed "timer" 1000 timer-cb)
    (update-widget
     'text-view (get-id "pf-timer-time-minutes") 'text
505
     (string-append (number->string (get-current 'timer-minutes pf-length))))
506
507
508
509
510
    (update-widget
     'text-view (get-id "pf-timer-time") 'text
     (string-append (number->string (get-current 'timer-seconds 59))))
    )))

Dave Griffiths's avatar
Dave Griffiths committed
511
(define (next-button id dialog-msg last-frag next-frag fn)
512
513
514
515
  (vert
   (spacer 30)
   (horiz
    (mbutton (string-append id "-backb") "Back"
Dave Griffiths's avatar
Dave Griffiths committed
516
517
518
             (lambda ()
               (list (replace-fragment (get-id "gc-top") last-frag))))

519
    (mbutton (string-append id "-nextb") "Next"
Dave Griffiths's avatar
Dave Griffiths committed
520
             (lambda ()
521
522
523
524
525
526
               (msg "update from next button")
               (entity-update-values!)
               (append
                (fn)
                (list
                 (replace-fragment (get-id "gc-top") next-frag))))))))
Dave Griffiths's avatar
Dave Griffiths committed
527

528
529
530
531
(define (force-pause)
  (list
   (delayed "timer" 1000 (lambda () '()))
   (update-widget 'toggle-button (get-id "pf-pause") 'checked 1)))
Dave Griffiths's avatar
Dave Griffiths committed
532

533

534
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
535

536
537
538
539
540
541
542
543
(define (update-selector-colours id entity-type where)
  (update-grid-selector-colours
   id "id-mongoose"
   (db-filter
    db "stream" entity-type
    (list
     (list "parent" "varchar" "=" (get-current 'group-composition-id 0))
     where))))
544

545
546
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; fragments
Dave Griffiths's avatar
Dave Griffiths committed
547
548
549

(define-fragment-list

550
551
552
  (fragment
   "pf-timer"
   (linear-layout
553
    (make-id "") 'vertical fillwrap trans-col
554
    (list
555
     (mtitle "pf-details" "Pack: xxx Pup: xxx")))
556
557
558
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
559
560
561
562
563
564
     (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"))
                     )))
565
566
567
568
569
570
571
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


  (fragment
572
   "events"
573
   (linear-layout
574
    0 'vertical fillwrap trans-col
575
    (list
576
     (linear-layout
Dave Griffiths's avatar
Dave Griffiths committed
577
      (make-id "ev-pf") 'vertical fill pf-col
578
      (list
579
580
       (mtitle "ev-pf-text" "Pup Focal Events")
       (horiz
Dave Griffiths's avatar
Dave Griffiths committed
581
582
583
584
        (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")))))))
585
     (linear-layout
586
      (make-id "ev-pf") 'vertical fill gp-col
587
      (list
588
589
       (mtitle "text" "Group Events")
       (horiz
Dave Griffiths's avatar
Dave Griffiths committed
590
591
        (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"))))
592
593
        (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")))))))))
594
595
596
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
597
     (if (equal? (get-current 'observation "none") obs-pf)
598
599
         (list
          (update-widget 'text-view (get-id "ev-pf-text") 'show 0)
Dave Griffiths's avatar
Dave Griffiths committed
600
601
602
603
          (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))))
604
605
606
607
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))
608

609
610
611
  (fragment
   "pf-scan1"
   (linear-layout
612
    (make-id "") 'vertical fillwrap pf-col
613
    (list
Dave Griffiths's avatar
Dave Griffiths committed
614
     (build-grid-selector "pf-scan-nearest" "single" "<b>Nearest Neighbour Scan</b>: Closest Mongoose")
615
     (build-grid-selector "pf-scan-close" "toggle" "Mongooses within 2m")
616
617
     (mbutton "pf-scan-done" "Done"
              (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
618
                (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
Dave Griffiths's avatar
Dave Griffiths committed
619
                (entity-record-values!)
620
                (list (replace-fragment (get-id "pf-top") "pf-timer"))))))
621
622
623
624

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
625
     (entity-init! db "stream" "pup-focal-nearest" '())
Dave Griffiths's avatar
Dave Griffiths committed
626
     (entity-set-value! "scan-time" "varchar" (date-time->string (date-time)))
627
     (list
628
629
      (play-sound "ping")
      (vibrate 300)
630
      (populate-grid-selector
631
       "pf-scan-nearest" "single"
632
       (db-mongooses-by-pack-adults) #t
633
       (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
634
         (entity-set-value! "id-nearest" "varchar" (ktv-get individual "unique_id"))
635
636
         (list)))
      (populate-grid-selector
637
       "pf-scan-close" "toggle"
638
       (db-mongooses-by-pack-adults) #t
639
       (lambda (individuals)
Dave Griffiths's avatar
Dave Griffiths committed
640
         (entity-set-value! "id-list-close" "varchar" (assemble-array individuals))
641
642
         (list)))
      ))
643
644
645
646
647
648
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


649
650
651
  (fragment
   "ev-pupfeed"
   (linear-layout
652
    (make-id "") 'vertical fillwrap pf-col
653
    (list
654
     (mtitle "title" "Event: Pup is fed")
655
     (build-grid-selector "pf-pupfeed-who" "single" "Who fed the pup?")
Dave Griffiths's avatar
Dave Griffiths committed
656
     (spacer 20)
657
     (horiz
Dave Griffiths's avatar
Dave Griffiths committed
658
      (mtext "text" "Food size")
659
      (spinner (make-id "pf-pupfeed-size") list-sizes fillwrap
660
               (lambda (v)
661
                 (entity-set-value! "size" "varchar" (list-ref list-sizes v)) '())))
Dave Griffiths's avatar
Dave Griffiths committed
662
663
     (spacer 20)
     (horiz
664
665
      (mbutton "pf-pupfeed-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
666
                 (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
Dave Griffiths's avatar
Dave Griffiths committed
667
                 (entity-record-values!)
668
669
670
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-pupfeed-cancel" "Cancel"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
671
                 (list (replace-fragment (get-id "event-holder") "events")))))))
672
673
674
675

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
676
     (entity-init!  db "stream" "pup-focal-pupfeed" '())
677
678
679
     (list
      (populate-grid-selector
       "pf-pupfeed-who" "single"
680
       (db-mongooses-by-pack-adults) #t
681
       (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
682
         (entity-set-value! "id-who" "varchar" (ktv-get individual "unique_id"))
683
684
685
686
687
688
689
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

Dave Griffiths's avatar
Dave Griffiths committed
690
691
692
  (fragment
   "ev-pupfind"
   (linear-layout
693
    (make-id "") 'vertical fillwrap pf-col
Dave Griffiths's avatar
Dave Griffiths committed
694
    (list
695
     (mtitle "title" "Event: Pup found food")
Dave Griffiths's avatar
Dave Griffiths committed
696
697
698
     (horiz
      (mtext "text" "Food size")
      (spinner (make-id "pf-pupfind-size") (list "Small" "Medium" "Large") fillwrap
Dave Griffiths's avatar
Dave Griffiths committed
699
               (lambda (v) (entity-set-value! "size" "varchar" v) '())))
Dave Griffiths's avatar
Dave Griffiths committed
700
     (spacer 20)
Dave Griffiths's avatar
Dave Griffiths committed
701
     (horiz
702
703
      (mbutton "pf-pupfind-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
704
                 (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
Dave Griffiths's avatar
Dave Griffiths committed
705
                 (entity-record-values!)
706
707
708
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-pupfind-cancel" "Cancel"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
709
                 (list (replace-fragment (get-id "event-holder") "events")))))))
Dave Griffiths's avatar
Dave Griffiths committed
710
711
712
713

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
714
     (entity-init! db "stream" "pup-focal-pupfind" '())
Dave Griffiths's avatar
Dave Griffiths committed
715
716
717
718
719
720
721
722
723
724
725
     (list
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


  (fragment
   "ev-pupcare"
   (linear-layout
726
    (make-id "") 'vertical fillwrap pf-col
Dave Griffiths's avatar
Dave Griffiths committed
727
    (list
728
     (mtitle "title" "Event: Pup is cared for")
Dave Griffiths's avatar
Dave Griffiths committed
729
     (build-grid-selector "pf-pupcare-who" "single" "Who cared for the pup?")
Dave Griffiths's avatar
Dave Griffiths committed
730
     (spacer 20)
Dave Griffiths's avatar
Dave Griffiths committed
731
     (horiz
Dave Griffiths's avatar
Dave Griffiths committed
732
      (mtext "text" "Type of care")
733
734
      (spinner (make-id "pf-pupcare-type") (list "Carry" "Lead" "Sniff" "Play" "Ano-genital sniff") fillwrap
               (lambda (v)
Dave Griffiths's avatar
Dave Griffiths committed
735
                 (entity-set-value! "type" "varchar" v) '())))
Dave Griffiths's avatar
Dave Griffiths committed
736
737
     (spacer 20)
     (horiz
738
739
      (mbutton "pf-pupcare-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
740
                 (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
Dave Griffiths's avatar
Dave Griffiths committed
741
                 (entity-record-values!)
742
743
744
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-pupcare-cancel" "Cancel"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
745
                 (list (replace-fragment (get-id "event-holder") "events")))))))
Dave Griffiths's avatar
Dave Griffiths committed
746
747
748
749

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
750
     (entity-init! db "stream" "pup-focal-pupcare" '())
Dave Griffiths's avatar
Dave Griffiths committed
751
752
753
     (list
      (populate-grid-selector
       "pf-pupcare-who" "single"
754
       (db-mongooses-by-pack-adults) #t
Dave Griffiths's avatar
Dave Griffiths committed
755
       (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
756
         (entity-set-value! "id-who" "varchar" (ktv-get individual "unique_id"))
Dave Griffiths's avatar
Dave Griffiths committed
757
758
759
760
761
762
763
764
765
766
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "ev-pupaggr"
   (linear-layout
767
    (make-id "") 'vertical fillwrap pf-col
Dave Griffiths's avatar
Dave Griffiths committed
768
    (list
769
     (mtitle "title" "Event: Pup aggression")
Dave Griffiths's avatar
Dave Griffiths committed
770
771
772
     (build-grid-selector "pf-pupaggr-partner" "single" "Aggressive mongoose")

     (linear-layout
773
      (make-id "") 'horizontal (layout 'fill-parent 100 '1 'left 0) trans-col
Dave Griffiths's avatar
Dave Griffiths committed
774
775
776
      (list
       (vert
        (mtext "" "Fighting over")
777
778
        (spinner (make-id "pf-pupaggr-over") (list "Food" "Escort" "Nothing" "Other") fillwrap
                 (lambda (v)
Dave Griffiths's avatar
Dave Griffiths committed
779
                   (entity-set-value! "over" "varchar" v) '())))
Dave Griffiths's avatar
Dave Griffiths committed
780
781
       (vert
        (mtext "" "Level")
782
783
        (spinner (make-id "pf-pupaggr-level") (list "Block" "Snap" "Chase" "Push" "Fight") fillwrap
                 (lambda (v)
Dave Griffiths's avatar
Dave Griffiths committed
784
                   (entity-set-value! "level" "varchar" v) '())))
785
786
787
788
789

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

       ;(mtoggle-button "pf-pupaggr-in" "Initiate?"
       ;                (lambda (v)
Dave Griffiths's avatar
Dave Griffiths committed
790
       ;                  (entity-set-value! "initiate" "varchar" (if v "yes" "no")) '()))
791
792
793
794


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

Dave Griffiths's avatar
Dave Griffiths committed
795
     (spacer 20)
796
797
798
     (horiz
      (mbutton "pf-pupaggr-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
799
                 (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
Dave Griffiths's avatar
Dave Griffiths committed
800
                 (entity-record-values!)
801
802
803
804
805
                 (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
806
807
808
809

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
810
     (entity-init! db "stream" "pup-focal-pupaggr" '())
Dave Griffiths's avatar
Dave Griffiths committed
811
812
813
     (list
      (populate-grid-selector
       "pf-pupaggr-partner" "single"
814
       (db-mongooses-by-pack) #t
Dave Griffiths's avatar
Dave Griffiths committed
815
       (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
816
         (entity-set-value! "id-with" "varchar" (ktv-get individual "unique_id"))
Dave Griffiths's avatar
Dave Griffiths committed
817
818
819
820
821
822
823
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

824
825
826
827
828
829
830
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (fragment
   "ev-grpint"
   (linear-layout
    (make-id "") 'vertical fillwrap gp-col
    (list
831
832
833
834
835
     (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
836
        (mtext "text" "Outcome")
837
        (spinner (make-id "gp-int-out") (list "Retreat" "Advance" "Fight retreat" "Fight win") fillwrap
838
                 (lambda (v)
Dave Griffiths's avatar
Dave Griffiths committed
839
                   (entity-set-value! "outcome" "varchar" v) '()))
840
        (mtext "text" "Duration")
841
        (edit-text (make-id "gp-int-dur") "" 30 "numeric" fillwrap
Dave Griffiths's avatar
Dave Griffiths committed
842
                   (lambda (v) (entity-set-value! "duration" "int" (string->number v)) '()))))
843
844
845
846
      (build-grid-selector "gp-int-pack" "single" "Other pack"))
     (linear-layout
      (make-id "") 'horizontal (layout 'fill-parent 80 '1 'left 0) trans-col
      (list
847
848
       (mbutton "pf-grpint-done" "Done"
                (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
849
                  (msg "entity-record-values about to be called?")
Dave Griffiths's avatar
Dave Griffiths committed
850
                  (entity-record-values!)
851
852
853
                  (list (replace-fragment (get-id "event-holder") "events"))))
       (mbutton "pf-grpint-cancel" "Cancel"
                (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
854
                  (list (replace-fragment (get-id "event-holder") "events"))))))))
855

856

857
858
859
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
860
     (entity-init! db "stream" "group-interaction" '())
861
862
863
864
865
     (append
      (force-pause)
      (list
       (populate-grid-selector
        "gp-int-pack" "single"
866
        (db-all-sort-normal db "sync" "pack") #f
867
        (lambda (pack)
Dave Griffiths's avatar
Dave Griffiths committed
868
          (entity-set-value! "id-other-pack" "varchar" (ktv-get pack "unique_id"))
869
870
871
          (list)))
       (populate-grid-selector
        "gp-int-leader" "single"
872
        (db-mongooses-by-pack) #t
873
        (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
874
          (entity-set-value! "id-leader" "varchar" (ktv-get individual "unique_id"))
875
876
          (list)))
       )))
877
878
879
880
881
882
883
884
885
886
887
888
889
   (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")
890
891
892
893
894
895
896
897

     (linear-layout
      (make-id "") 'horizontal fillwrap trans-col
      (list
       (vert
        (mtext "text" "Cause")
        (spinner (make-id "gp-alarm-cause") (list "Predator" "Other mongoose pack" "Humans" "Other" "Unknown") fillwrap
                 (lambda (v)
Dave Griffiths's avatar
Dave Griffiths committed
898
                   (entity-set-value! "cause" "varchar" v) '())))
899
900
901

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

902
903
904
     (horiz
      (mbutton "pf-grpalarm-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
905
                 (entity-record-values!)
906
907
908
909
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-grpalarm-cancel" "Cancel"
               (lambda ()
                 (list (replace-fragment (get-id "event-holder") "events")))))))
910
911
912
913

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
914
     (entity-init! db "stream" "group-alarm" '())
915
916
917
918
919
     (append
      (force-pause)
      (list
       (populate-grid-selector
        "gp-alarm-caller" "single"
920
        (db-mongooses-by-pack) #t
921
        (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
922
          (entity-set-value! "id-caller" "varchar" (ktv-get individual "unique_id"))
923
          (list))))
924
925
926
927
928
929
930
931
932
933
934
      ))
   (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
935
     (build-grid-selector "gp-mov-leader" "single" "<b>Group movement</b>: Leader")
936
     (linear-layout
937
      (make-id "") 'horizontal (layout 'fill-parent 'wrap-content '1 'left 0) trans-col
938
      (list
Dave Griffiths's avatar
Dave Griffiths committed
939
       (medit-text "gp-mov-w" "Pack width" "numeric"
Dave Griffiths's avatar
Dave Griffiths committed
940
                   (lambda (v) (entity-set-value! "pack-width" "int" (string->number v)) '()))
Dave Griffiths's avatar
Dave Griffiths committed
941
       (medit-text "gp-mov-l" "Pack depth" "numeric"
Dave Griffiths's avatar
Dave Griffiths committed
942
                   (lambda (v) (entity-set-value! "pack-depth" "int" (string->number v)) '()))
Dave Griffiths's avatar
Dave Griffiths committed
943
       (medit-text "gp-mov-c" "How many?" "numeric"
Dave Griffiths's avatar
Dave Griffiths committed
944
                   (lambda (v) (entity-set-value! "pack-count" "int" (string->number v)) '()))))
945
     (linear-layout
946
      (make-id "") 'horizontal (layout 'fill-parent 'wrap-content '1 'left 0) trans-col
947
      (list
948
949
       (vert
        (mtext "" "Direction")
950
        (spinner (make-id "gp-mov-dir") (list "To" "From") fillwrap
Dave Griffiths's avatar
Dave Griffiths committed
951
                 (lambda (v) (entity-set-value! "direction" "varchar" v)  '())))
952

Dave Griffiths's avatar
Dave Griffiths committed
953
954
955
       (vert
        (mtext "" "Where to")
        (spinner (make-id "gp-mov-to") (list "Latrine" "Water" "Food" "Nothing" "Den" "Unknown") fillwrap
Dave Griffiths's avatar
Dave Griffiths committed
956
                 (lambda (v) (entity-set-value! "destination" "varchar" v)  '())))))
Dave Griffiths's avatar
Dave Griffiths committed
957
958
959
960
961

     (spacer 20)
     (horiz
      (mbutton "pf-grpmov-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
962
                 (entity-record-values!)
Dave Griffiths's avatar
Dave Griffiths committed
963
964
965
966
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-grpalarm-cancel" "Cancel"
               (lambda ()
                 (list (replace-fragment (get-id "event-holder") "events")))))))
967
968
969
970

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
971
     (entity-init! db "stream" "group-move" '())
972
973
974
975
976
     (append
      (force-pause)
      (list
       (populate-grid-selector
        "gp-mov-leader" "single"
977
        (db-mongooses-by-pack) #t
978
        (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
979
          (entity-set-value! "id-leader" "varchar" (ktv-get individual "unique_id"))
980
981
          (list)))
       )))
982
983
984
985
986
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

987
988
989
990
991
992
  (fragment
   "note"
   (linear-layout
    (make-id "") 'vertical fillwrap gp-col
    (list
     (mtitle "title" "Make a note")
993
     (edit-text (make-id "note-text") "" 30 "text" fillwrap
994
                (lambda (v)
Dave Griffiths's avatar
Dave Griffiths committed
995
                  (entity-set-value! "text" "varchar" v)
996
997
998
999
                  '()))
     (horiz
      (mbutton "note-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
1000
                 (entity-record-values!)
1001
1002
1003
1004
1005
1006
1007
                 (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))
1008
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
1009
     (entity-init!  db "stream" "note" '())
1010
1011
1012
1013
     (append
      (force-pause)
      (list
       (update-widget 'edit-text (get-id "note-text") 'request-focus 1))))
1014
1015
1016
1017
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))
1018
1019
1020
1021


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

1022

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

Dave Griffiths's avatar
Dave Griffiths committed
1025
  (fragment
1026
   "gc-start"
1027
   (linear-layout
1028
    (make-id "") 'vertical fill gc-col
1029
1030
    (list
     (mtitle "title" "Start")
1031
1032
1033
1034
1035
1036
1037
     (horiz
      (mtoggle-button "gc-start-main-obs" "I'm the main observer"
                      (lambda (v) (entity-set-value! "main-observer" "varchar" v) '()))
      (vert
       (mtext "" "Code")
       (edit-text (make-id "gc-start-code") "" 30 "numeric" fillwrap
                  (lambda (v) (entity-set-value! "group-comp-code" "varchar" v) '()))))
Dave Griffiths's avatar
Dave Griffiths committed
1038
     (build-grid-selector "gc-start-present" "toggle" "Who's present?")
Dave Griffiths's avatar
Dave Griffiths committed
1039
     (next-button "gc-start-" "Go to weighing, have you finished here?" "gc-start" "gc-weights"
1040
                  (lambda ()
1041
                    (set-current! 'gc-present (string-split-simple (entity-get-value "present") #\,))
1042
1043
1044
                    (entity-update-values!)
                    (msg "exiting start")
                    '()))
Dave Griffiths's avatar
Dave Griffiths committed
1045
     ))
1046
1047
1048
1049

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
1050
1051
1052
     ;; in case we come back from weights...
     (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
1053

1054
1055
1056
1057
1058
1059
1060
1061
1062
     (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))
        (get-current 'gc-present '())))
1063
      (update-grid-selector-checked "gc-start-present" "present"))
1064
     )
1065
1066
1067
1068
1069
1070
1071
1072
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment