starwisp.scm 66.7 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))
Dave Griffiths's avatar
Dave Griffiths committed
526
     (entity-init! db "stream" "group-comp"
527
                   (get-entity-by-unique db "stream" (get-current 'group-composition-id #f)))
Dave Griffiths's avatar
Dave Griffiths committed
528

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

536
537
538
539
540
541
       (populate-grid-selector
        "gc-start-present" "toggle"
        (db-mongooses-by-pack) #f
        (lambda (individuals)
          (entity-set-value! "present" "varchar" (assemble-array individuals))
          (list))
542
543
544
        ;; need to invert, but not () if there are none set yet...
        (let ((r (get-current 'gc-not-present #f)))
          (if (not r) '() (invert-mongoose-selection r)))))
545
      (update-grid-selector-checked "gc-start-present" "present"))
546
     )
547
548
549
550
551
552
553
554
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "gc-weights"
   (linear-layout
555
    (make-id "") 'vertical fill gc-col
556
557
    (list
     (mtitle "title" "Weights")
Dave Griffiths's avatar
Dave Griffiths committed
558
     (build-grid-selector "gc-weigh-choose" "single" "Choose mongoose")
Dave Griffiths's avatar
Dave Griffiths committed
559
560
561
562
563
564
565
566
567
568
     (spacer 20)
     (horiz
      (edit-text (make-id "gc-weigh-weight") "" 30 "numeric" fillwrap
                 (lambda (v)
                   (entity-update-single-value! (ktv "weight" "real" (string->number v)))
                   '()))
      (mtoggle-button "gc-weigh-accurate" "Accurate?"
                      (lambda (v)
                        (entity-update-single-value! (ktv "accurate" "int" (if v 1 0)))
                        '())))
Dave Griffiths's avatar
Dave Griffiths committed
569
     (next-button "gc-weigh-" "Go to pregnancies, have you finished here?" "gc-start" "gc-preg"
570
571
                  (lambda ()
                    ;; reset main entity
Dave Griffiths's avatar
Dave Griffiths committed
572
                    (entity-init! db "stream" "group-comp"
573
574
                                  (get-entity-by-unique db "stream" (get-current 'group-composition-id #f)))
                    '()))))
575
576
577
578

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

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

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
628
629
630
631
632
633
634
635
636
     (append
      (list
       (populate-grid-selector
        "gc-preg-choose" "toggle"
        (db-mongooses-by-pack-female) #f
        (lambda (individuals)
          (entity-update-single-value! (ktv "pregnant" "varchar" (assemble-array individuals)))
          (list)))
       )
Dave Griffiths's avatar
Dave Griffiths committed
637
      (update-grid-selector-enabled "gc-preg-choose" (get-current 'gc-not-present '()))
638
      (update-grid-selector-checked "gc-preg-choose" "pregnant")))
639
640
641
642
643
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

644

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

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

688
689
690
       (populate-grid-selector
        "gc-pup-choose" "single"
        (db-mongooses-by-pack-pups) #f
691
692
693
694
695
696
697
        (lambda (pup-individual)
          (append
           (list
            (populate-grid-selector
             "gc-pup-escort" "single"
             (db-mongooses-by-pack-adults) #t
             (lambda (escort-individual)
Dave Griffiths's avatar
Dave Griffiths committed
698
               (msg "escort-individual clicked")
699
               (let ((s (db-filter
Dave Griffiths's avatar
Dave Griffiths committed
700
                         db "stream" "group-comp-pup-assoc"
701
702
703
704
705
                         (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
Dave Griffiths's avatar
Dave Griffiths committed
706
                     (entity-init&save! db "stream" "group-comp-pup-assoc"
707
708
709
                                        (list
                                         (ktv "name" "varchar" "")
                                         (ktv "id-escort" "varchar" (ktv-get escort-individual "unique_id"))
Dave Griffiths's avatar
Dave Griffiths committed
710
711
                                         (ktv "accurate" "varchar" "none")
                                         (ktv "strength" "varchar" "none")
712
713
                                         (ktv "parent" "varchar" (get-current 'group-composition-id 0))
                                         (ktv "id-mongoose" "varchar" (ktv-get pup-individual "unique_id"))))
Dave Griffiths's avatar
Dave Griffiths committed
714
                     (entity-init! db "stream" "group-comp-pup-assoc" (car s)))
715
716
717
718
719
                 (append
                  (list
                   (update-widget 'spinner (get-id "gc-pup-strength") 'selection (spinner-index list-strength (entity-get-value "strength")))
                   (update-widget 'spinner (get-id "gc-pup-accuracy") 'selection (spinner-index list-strength (entity-get-value "accurate"))))

Dave Griffiths's avatar
Dave Griffiths committed
720
                  (update-selector-colours2
Dave Griffiths's avatar
Dave Griffiths committed
721
                   "gc-pup-escort" "group-comp-pup-assoc"
Dave Griffiths's avatar
Dave Griffiths committed
722
723
724
725
                   (list
                    (list "id-mongoose" "varchar" "=" (ktv-get pup-individual "unique_id"))
                    (list "strength" "varchar" "!=" "none")
                    (list "accurate" "varchar" "!=" "none"))))
726
727

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

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

747
748


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

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

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

798
799
800
       (populate-grid-selector
        "gc-oestrus-female" "single"
        (db-mongooses-by-pack-female) #f
Dave Griffiths's avatar
Dave Griffiths committed
801
802
803
804
805
806
807
808
        (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
Dave Griffiths's avatar
Dave Griffiths committed
809
                         db "stream" "group-comp-mate-guard"
Dave Griffiths's avatar
Dave Griffiths committed
810
811
812
813
814
                         (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
Dave Griffiths's avatar
Dave Griffiths committed
815
                     (entity-init&save! db "stream" "group-comp-mate-guard"
Dave Griffiths's avatar
Dave Griffiths committed
816
817
818
                                        (list
                                         (ktv "name" "varchar" "")
                                         (ktv "id-escort" "varchar" (ktv-get escort-individual "unique_id"))
Dave Griffiths's avatar
Dave Griffiths committed
819
820
                                         (ktv "accurate" "varchar" "none")
                                         (ktv "strength" "varchar" "none")
821
                                         (ktv "pester" "int" 0)
Dave Griffiths's avatar
Dave Griffiths committed
822
823
                                         (ktv "parent" "varchar" (get-current 'group-composition-id 0))
                                         (ktv "id-mongoose" "varchar" (ktv-get pup-individual "unique_id"))))
Dave Griffiths's avatar
Dave Griffiths committed
824
                     (entity-init! db "stream" "group-comp-mate-guard" (car s)))
Dave Griffiths's avatar
Dave Griffiths committed
825
826
827
                 (append
                  (list
                   (update-widget 'spinner (get-id "gc-oestrus-strength") 'selection (spinner-index list-strength (entity-get-value "strength")))
828
829
                   (update-widget 'spinner (get-id "gc-oestrus-accuracy") 'selection (spinner-index list-strength (entity-get-value "accurate")))
                   (update-widget 'toggle-button (get-id "gc-oestrus-pester") 'checked (entity-get-value "pester")))
Dave Griffiths's avatar
Dave Griffiths committed
830

Dave Griffiths's avatar
Dave Griffiths committed
831
                  (update-selector-colours2
Dave Griffiths's avatar
Dave Griffiths committed
832
                   "gc-oestrus-guard" "group-comp-mate-guard"
Dave Griffiths's avatar
Dave Griffiths committed
833
834
835
836
                   (list
                    (list "id-mongoose" "varchar" "=" (ktv-get pup-individual "unique_id"))
                    (list "strength" "varchar" "!=" "none")
                    (list "accurate" "varchar" "!=" "none"))))
Dave Griffiths's avatar
Dave Griffiths committed
837
                 ))))
Dave Griffiths's avatar
Dave Griffiths committed
838
           (update-selector-colours2
Dave Griffiths's avatar
Dave Griffiths committed
839
            "gc-oestrus-guard" "group-comp-mate-guard"
Dave Griffiths's avatar
Dave Griffiths committed
840
841
842
843
            (list
             (list "id-mongoose" "varchar" "=" (ktv-get pup-individual "unique_id"))
             (list "strength" "varchar" "!=" "none")
             (list "accurate" "varchar" "!=" "none")))
Dave Griffiths's avatar
Dave Griffiths committed
844
           (update-selector-colours3 "gc-oestrus-female" "group-comp-mate-guard")
Dave Griffiths's avatar
Dave Griffiths committed
845
           (update-grid-selector-enabled "gc-oestrus-guard" (get-current 'gc-not-present '()))
Dave Griffiths's avatar
Dave Griffiths committed
846
           ))))
Dave Griffiths's avatar
Dave Griffiths committed
847
848
      (update-grid-selector-enabled "gc-oestrus-guard" (get-current 'gc-not-present '()))
      (update-grid-selector-enabled "gc-oestrus-female" (get-current 'gc-not-present '()))
Dave Griffiths's avatar
Dave Griffiths committed
849
      (update-selector-colours3 "gc-oestrus-female" "group-comp-mate-guard")
Dave Griffiths's avatar
Dave Griffiths committed
850
      ))
851

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

  (fragment
   "gc-babysitting"
   (linear-layout
860
    (make-id "") 'vertical fill gc-col
861
    (list
Dave Griffiths's avatar
Dave Griffiths committed
862
     (mtitle "" "Babysitters")
Dave Griffiths's avatar
Dave Griffiths committed
863
864
865
866
     (mtitle "title" "Seen")
     (build-grid-selector "gc-baby-seen" "toggle" "Choose")
     (mtitle "title" "By elimination")
     (build-grid-selector "gc-baby-byelim" "toggle" "Choose")
Dave Griffiths's avatar
Dave Griffiths committed
867
     (next-button "gc-pup-baby-" "Ending, have you finished here?" "gc-oestrus" "gc-end"
Dave Griffiths's avatar
Dave Griffiths committed
868
                  (lambda () '()))))
869
870
871
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
872
873
874
875
876
877
878
879
880
     (append
      (list
       (populate-grid-selector
        "gc-baby-seen" "toggle"
        (db-mongooses-by-pack-adults) #f
        (lambda (individuals)
          (entity-update-single-value! (ktv "baby-seen" "varchar" (assemble-array individuals)))
          (list)))
       )
Dave Griffiths's avatar
Dave Griffiths committed
881
      (update-grid-selector-enabled "gc-baby-seen" (get-current 'gc-not-present '()))
Dave Griffiths's avatar
Dave Griffiths committed
882
883
884
885
886
887
888
889
890
      (update-grid-selector-checked "gc-baby-seen" "baby-seen")
      (list
       (populate-grid-selector
        "gc-baby-byelim" "toggle"
        (db-mongooses-by-pack-adults) #f
        (lambda (individuals)
          (entity-update-single-value! (ktv "baby-byelim" "varchar" (assemble-array individuals)))
          (list)))
       )
Dave Griffiths's avatar
Dave Griffiths committed
891
      (update-grid-selector-enabled "gc-baby-byelim" (get-current 'gc-not-present '()))
Dave Griffiths's avatar
Dave Griffiths committed
892
      (update-grid-selector-checked "gc-baby-byelim" "baby-byelim")))
893
894
895
896
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))
897

898
899
900
  (fragment
   "gc-end"
   (linear-layout
901
    (make-id "") 'vertical fill gc-col
902
    (list
Dave Griffiths's avatar
Dave Griffiths committed
903
     (mtitle "" "Finish group composition")
Dave Griffiths's avatar
Dave Griffiths committed
904
     (next-button "gc-pup-baby-" "Ending, have you finished here?" "gc-babysitting" "gc-end"
905
906
907
908
909
                  (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
910
911
   (lambda (fragment arg)
     (activity-layout fragment))
912
913
   (lambda (fragment arg)
     (list))
Dave Griffiths's avatar
Dave Griffiths committed
914
915
916
917
918
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

919
920


Dave Griffiths's avatar
Dave Griffiths committed
921
922
  )

923
924
925
926
(msg "one")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; activities
Dave Griffiths's avatar
Dave Griffiths committed
927

928
(define-activity-list
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
;  (activity
;   "splash"
;   (vert
;    (text-view (make-id "splash-title") "Mongoose 2000" 40 fillwrap)
;    (mtext "splash-about" "Advanced mongoose technology")
;    (spacer 20)
;    (mbutton2 "f2" "Get started!" (lambda () (list (start-activity-goto "main" 2 ""))))
;    )
;
;   (lambda (activity arg)
;     (activity-layout activity))
;   (lambda (activity arg)
;     (list))
;   (lambda (activity) '())
;   (lambda (activity) '())
;   (lambda (activity) '())
;   (lambda (activity) '())
;   (lambda (activity requestcode resultcode) '()))
947

Dave Griffiths's avatar
Dave Griffiths committed
948

949
950
951
  (activity
   "main"
   (vert
952
953
    (text-view (make-id "main-title") "Mongoose 2000" 50 fillwrap)
    (text-view (make-id "main-about") "Advanced mongoose technology" 30 fillwrap)
954
    (spacer 10)
955
956
    (horiz
     (mbutton2 "main-observations" "Observations" (lambda () (list (start-activity "observations" 2 ""))))
Dave Griffiths's avatar
Dave Griffiths committed
957
     (mbutton2 "main-manage" "Manage Packs" (lambda () (list (start-activity "manage-packs" 2 "")))))
Dave Griffiths's avatar
Dave Griffiths committed
958
959

    (image-view 0 "mongooses" fillwrap)
960
    (mtext "foo" "Your ID")
Dave Griffiths's avatar
Dave Griffiths committed
961
    (edit-text (make-id "main-id-text") "" 30 "text" fillwrap
962
963
964
               (lambda (v)
                 (set-current! 'user-id v)
                 (update-entity
Dave Griffiths's avatar
Dave Griffiths committed
965
966
                  db "local" 1 (list (ktv "user-id" "varchar" v)))
                 '()))
Dave Griffiths's avatar
Dave Griffiths committed
967
    (mtext "foo" "Database")
Dave Griffiths's avatar
Dave Griffiths committed
968
    (horiz
Dave Griffiths's avatar
Dave Griffiths committed
969
970
     (mbutton2 "main-review" "Review changes" (lambda () (list (start-activity "review" 0 ""))))
     (mbutton2 "main-sync" "Sync database" (lambda () (list (start-activity "sync" 0 ""))))))
Dave Griffiths's avatar
Dave Griffiths committed
971
972
   (lambda (activity arg)
     (activity-layout activity))
973
   (lambda (activity arg)
Dave Griffiths's avatar
Dave Griffiths committed
974
     (msg "on-start")
975
     (setup-database!)
976
977
     (let ((user-id (ktv-get (get-entity db "local" 1) "user-id")))
       (set-current! 'user-id user-id)
Dave Griffiths's avatar
Dave Griffiths committed
978
       (msg "on-start 2")
979
980
       (list
        (gps-start "gps" (lambda (loc)