starwisp.scm 55.2 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
;; colours

37
38
39
40
41
42
43
44
45
46
47
48
(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))

49
50
51


(define trans-col (list 0 0 0 0))
52
53
54
55
56
57
58
59
60
61
62
63
64
65

(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")
66
   (list "Pup assoc" "gc-pup-assoc")
67
68
69
70
   (list "Oestrus" "gc-oestrus")
   (list "Babysit" "gc-babysitting")
   (list "End" "gc-end")))

71
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Dave Griffiths's avatar
Dave Griffiths committed
72
;; persistent database
73

74
(define db "/sdcard/mongoose/local-mongoose.db")
Dave Griffiths's avatar
Dave Griffiths committed
75
(db-open db)
76
77
78
79
80
81
82
83
84
85
(setup db "local")
(setup db "sync")
(setup db "stream")

(insert-entity-if-not-exists
 db "local" "app-settings" "null" 1
 (list
  (ktv "user-id" "varchar" "No name yet...")))

(display (db-all db "local" "app-settings"))(newline)
Dave Griffiths's avatar
Dave Griffiths committed
86

Dave Griffiths's avatar
Dave Griffiths committed
87
88
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; stuff in memory
Dave Griffiths's avatar
Dave Griffiths committed
89

Dave Griffiths's avatar
Dave Griffiths committed
90
91
(define (store-set store key value)
  (cond
92
93
94
95
96
   ((null? store) (list (list key value)))
   ((eq? key (car (car store)))
    (cons (list key value) (cdr store)))
   (else
    (cons (car store) (store-set (cdr store) key value)))))
Dave Griffiths's avatar
Dave Griffiths committed
97

Dave Griffiths's avatar
Dave Griffiths committed
98
(define (store-get store key default)
Dave Griffiths's avatar
Dave Griffiths committed
99
  (cond
100
101
102
103
104
105
106
107
108
109
110
111
112
   ((null? store) default)
   ((eq? key (car (car store)))
    (cadr (car store)))
   (else
    (store-get (cdr store) key default))))

(define (store-exists? store key)
  (cond
   ((null? store) #f)
   ((eq? key (car (car store)))
    #t)
   (else
    (store-exists? (cdr store) key))))
Dave Griffiths's avatar
Dave Griffiths committed
113

Dave Griffiths's avatar
Dave Griffiths committed
114
(define store '())
Dave Griffiths's avatar
Dave Griffiths committed
115

Dave Griffiths's avatar
Dave Griffiths committed
116
117
(define (set-current! key value)
  (set! store (store-set store key value)))
Dave Griffiths's avatar
Dave Griffiths committed
118

Dave Griffiths's avatar
Dave Griffiths committed
119
120
(define (get-current key default)
  (store-get store key default))
Dave Griffiths's avatar
Dave Griffiths committed
121

122
123
124
(define (current-exists? key)
  (store-exists? store key))

125
126
127
128
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; db abstraction

;; store a ktv, replaces existing with same key
129
130
131
(define (entity-add-value! key type value)
  (set-current!
   'entity-values
132
   (ktv-set
133
134
    (get-current 'entity-values '())
    (ktv key type value))))
135

Dave Griffiths's avatar
Dave Griffiths committed
136
137
138
(define (entity-set! ktv-list)
  (set-current! 'entity-values ktv-list))

139
140
141
142
143
144
145
(define (dt->string dt)
  (string-append
   (number->string (list-ref dt 0)) "-"
   (number->string (list-ref dt 1)) "-"
   (number->string (list-ref dt 2)) "T"
   (number->string (list-ref dt 3)) ":"
   (number->string (list-ref dt 4)) ":"
146
   (substring (number->string (+ 100 (list-ref dt 5))) 1 2)))
147

148
149
;; build entity from all ktvs, insert to db, return unique_id
(define (entity-record-values db table type)
150
151
152
153
154
  ;; standard bits
  (entity-add-value! "user" "varchar" (get-current 'user-id "none"))
  (entity-add-value! "time" "varchar" (dt->string (date-time)))
  (entity-add-value! "lat" "real" 0)
  (entity-add-value! "lon" "real" 0)
155
156
157
158
159
160
161
162
163
164
165
166
  (let ((values (get-current 'entity-values '())))
    (msg values)
    (cond
     ((not (null? values))
      (let ((r (insert-entity/get-unique
                db table type (get-current 'user-id "no id")
                values)))
        (msg "inserted a " type)
        (entity-reset!) r))
     (else
      (msg "no values to add as entity!") #f))))

Dave Griffiths's avatar
Dave Griffiths committed
167
168
169
170
171
172
173
174
175
176
177
178
(define (entity-update-values db table)
  ;; standard bits
  (let ((values (get-current 'entity-values '()))
        (unique-id (ktv-get (get-current 'entity-values '()) "unique_id")))
    (cond
     ((and unique-id (not (null? values)))
      (update-entity db table (entity-id-from-unique db table unique-id) values)
      (msg "updated " unique-id)
      (entity-reset!))
     (else
      (msg "no values or no id to update as entity:" unique-id "values:" values)))))

179
180
181
182
183
184
185
186
187
188
(define (entity-reset!)
  (set-current! 'entity-values '()))

(define (assemble-array entities)
  (foldl
   (lambda (i r)
     (if (equal? r "") (ktv-get i "unique_id")
         (string-append r "," (ktv-get i "unique_id"))))
   ""
   entities))
189

Dave Griffiths's avatar
Dave Griffiths committed
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; syncing code

(define url "http://192.168.2.1:8888/mongoose?")

(define (build-url-from-ktv ktv)
  (string-append "&" (ktv-key ktv) ":" (ktv-type ktv) "=" (stringify-value-url ktv)))

(define (build-url-from-ktvlist ktvlist)
  (foldl
   (lambda (ktv r)
     (string-append r (build-url-from-ktv ktv)))
   "" ktvlist))

(define (build-url-from-entity table e)
  (string-append
   url
   "fn=sync"
   "&table=" table
   "&entity-type=" (list-ref (car e) 0)
   "&unique-id=" (list-ref (car e) 1)
Dave Griffiths's avatar
Dave Griffiths committed
211
212
   "&dirty=" (number->string (list-ref (car e) 2))
   "&version=" (number->string (list-ref (car e) 3))
Dave Griffiths's avatar
Dave Griffiths committed
213
214
215
216
217
218
219
220
221
222
   (build-url-from-ktvlist (cadr e))))

;; spit all dirty entities to server
(define (spit-dirty db table)
  (map
   (lambda (e)
     (http-request
      (string-append "req-" (list-ref (car e) 1))
      (build-url-from-entity table e)
      (lambda (v)
223
        (msg "spat" e v)
Dave Griffiths's avatar
Dave Griffiths committed
224
225
226
        (if (or
             (equal? (car v) "inserted")
             (equal? (car v) "match"))
Dave Griffiths's avatar
Dave Griffiths committed
227
            (begin
Dave Griffiths's avatar
Dave Griffiths committed
228
              (msg "cleaning...")
Dave Griffiths's avatar
Dave Griffiths committed
229
              (update-entity-clean db table (cadr v))
Dave Griffiths's avatar
Dave Griffiths committed
230
231
              (list (toast (string-append "Uploaded " (car (car e))))))
            (list (toast (string-append "Problem uploading " (car (car e)))))))))
232
   (dirty-entities db table)))
Dave Griffiths's avatar
Dave Griffiths committed
233

234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
;; spit all dirty entities to server
(define (spit-all db table)
  (map
   (lambda (e)
     (msg "spit all" e)
     (http-request
      (string-append "req-" (list-ref (car e) 1))
      (build-url-from-entity table e)
      (lambda (v)
        (msg "spat" e v)
        (if (equal? (car v) "inserted")
            (begin
              (update-entity-clean db table (cadr v))
              (toast (string-append "Uploaded " (car (car e)))))
            (toast (string-append "Problem uploading " (car (car e))))))))
   (dirty-and-all-entities db table)))


252
(define (suck-entity-from-server db table unique-id exists)
Dave Griffiths's avatar
Dave Griffiths committed
253
254
255
256
257
258
259
  ;; ask for the current version
  (http-request
   (string-append unique-id "-update-new")
   (string-append url "fn=entity&table=" table "&unique-id=" unique-id)
   (lambda (data)
     (msg "data from server request" data)
     ;; check "sync-insert" in sync.ss raspberry pi-side for the contents of 'entity'
260
261
     (let ((entity (list-ref data 0))
           (ktvlist (list-ref data 1)))
Dave Griffiths's avatar
Dave Griffiths committed
262
       (if (not exists)
263
264
265
266
267
268
269
270
           (begin
             (insert-entity-wholesale
              db table
              (list-ref entity 0) ;; entity-type
              (list-ref entity 1) ;; unique-id
              0 ;; dirty
              (list-ref entity 2) ;; version
              ktvlist))
Dave Griffiths's avatar
Dave Griffiths committed
271
272
           (update-to-version
            db table (get-entity-id db table unique-id)
Dave Griffiths's avatar
Dave Griffiths committed
273
274
275
276
            (list-ref entity 4) ktvlist))
       (list
        (update-widget 'text-view (get-id "sync-dirty") 'text (build-dirty))
        (toast (string-append "Downloaded " (ktv-get ktvlist "name"))))))))
Dave Griffiths's avatar
Dave Griffiths committed
277

Dave Griffiths's avatar
Dave Griffiths committed
278
;; repeatedly read version and request updates
Dave Griffiths's avatar
Dave Griffiths committed
279
(define (suck-new db table)
Dave Griffiths's avatar
Dave Griffiths committed
280
281
282
  (list
   (http-request
    "new-entities-req"
283
    (string-append url "fn=entity-versions&table=" table)
Dave Griffiths's avatar
Dave Griffiths committed
284
    (lambda (data)
Dave Griffiths's avatar
Dave Griffiths committed
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
      (let ((r (foldl
                (lambda (i r)
                  (let* ((unique-id (car i))
                         (version (cadr i))
                         (exists (entity-exists? db table unique-id))
                         (old
                          (if exists
                              (> version (get-entity-version
                                          db table
                                          (get-entity-id db table unique-id)))
                              #f)))
                    ;; if we don't have this entity or the version on the server is newer
                    (if (or (not exists) old)
                        (cons (suck-entity-from-server db table unique-id exists) r)
                        r)))
                '()
                data)))
        (if (null? r)
            (cons (toast "All files up to date") r)
            (cons (toast "Requesting " (length r) " entities") r)))))))
Dave Griffiths's avatar
Dave Griffiths committed
305

306
307
308
309
310
311
312
313
314
(define (build-dirty)
  (let ((sync (get-dirty-stats db "sync"))
        (stream (get-dirty-stats db "stream")))
    (msg sync stream)
    (string-append
     "Pack data: " (number->string (car sync)) "/" (number->string (cadr sync)) " "
     "Focal data: " (number->string (car stream)) "/" (number->string (cadr stream)))))


Dave Griffiths's avatar
Dave Griffiths committed
315
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
316
;; user interface abstraction
Dave Griffiths's avatar
Dave Griffiths committed
317

Dave Griffiths's avatar
Dave Griffiths committed
318
319
320
(define (mbutton id title fn)
  (button (make-id id) title 20 fillwrap fn))

321
(define (mbutton2 id title fn)
322
  (button (make-id id) title 20 (layout 150 100 1 'centre 0) fn))
323

324
325
326
(define (mtoggle-button id title fn)
  (toggle-button (make-id id) title 20 fillwrap fn))

327
(define (mtoggle-button2 id title fn)
328
  (toggle-button (make-id id) title 20 (layout 150 100 1 'centre 0) fn))
329

Dave Griffiths's avatar
Dave Griffiths committed
330
331
(define (mtext id text)
  (text-view (make-id id) text 20 fillwrap))
332

333
334
335
(define (mtitle id text)
  (text-view (make-id id) text 40 fillwrap))

336
337
(define (medit-text id text type fn)
  (vert
338
339
   (mtext (string-append id "-title") text)
   (edit-text (make-id id) "" 20 type fillwrap fn)))
340
341
342
343
344
345
346

(define (mclear-toggles id-list)
  (map
   (lambda (id)
     (update-widget 'toggle-button (get-id id) 'checked 0))
   id-list))

347
348
349
350
351
352
353
(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))

354
355
356
357
358
359
360
361
362
363
(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))

364
365
;;;;

366
(define (build-grid-selector name type title)
367
  (vert
368
   (mtext "title" title)
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
   (linear-layout
    0 'horizontal
    (layout 'fill-parent 'fill-parent 1 'left 2) trans-col
    (list
     (image-view (make-id "im") "arrow_left" (layout 100 'fill-parent 1 'left 0))
     (scroll-view
      (make-id "scroller")
      (layout 'wrap-content 'wrap-content 1 'left 20)
      (list
       (linear-layout
        (make-id name) 'horizontal
        (layout 'wrap-content 'wrap-content 1 'centre 20) trans-col
        (list
         (button-grid (make-id name) type 3 20 (layout 100 40 1 'left 40)
                      (list) (lambda (v) '()))))))
     (image-view (make-id "im") "arrow_right" (layout 100 'fill-parent 1 'right 0))))))
385

386
;; assumes grid selectors on mongeese only
387
388
389
(define (fast-get-name item)
  (list-ref (list-ref item 1) 2))

390
391
392
393
394
395
396
397
398
(define (build-button-items name items)
  (map
   (lambda (item)
     (let ((item-name (fast-get-name item)))
       (list (make-id (string-append name item-name))
             item
             item-name)))
   items))

399
400
401
(define (populate-grid-selector name type items fn)
  (let ((id->items (build-button-items name items))
        (selected-set '()))
402
403
404
    (update-widget
     'button-grid (get-id name) 'grid-buttons
     (list
405
      type 3 20 (layout 100 40 1 'left 0)
406
407
408
409
      (map
       (lambda (ii)
         (list (car ii) (caddr ii)))
       id->items)
410
411
      (lambda (v state)
        (cond
412
413
         ((equal? type "toggle")
          ;; update list of selected items
414
415
416
417
418
419
420
421
422
423
          (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))
424
425
          (fn (cadr (findv v id->items))))))))))

426
427
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
Dave Griffiths's avatar
Dave Griffiths committed
428

429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
(define (timer-cb)
  (set-current!
   'timer-seconds
   (- (get-current 'timer-seconds 59) 1))
  (append
   (cond
    ((< (get-current 'timer-seconds 59) 0)
     (set-current! 'timer-minutes (- (get-current 'timer-minutes 20) 1))
     (set-current! 'timer-seconds 59)
     (list
      (replace-fragment (get-id "pf-top") "pf-scan1")))
    (else '()))
   (list
    (delayed "timer" 1000 timer-cb)
    (update-widget
     'text-view (get-id "pf-timer-time-minutes") 'text
     (string-append (number->string (get-current 'timer-minutes 20))))
    (update-widget
     'text-view (get-id "pf-timer-time") 'text
     (string-append (number->string (get-current 'timer-seconds 59))))
    )))

451
452
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; fragments
Dave Griffiths's avatar
Dave Griffiths committed
453
454
455

(define-fragment-list

456
457
458
  (fragment
   "pf-timer"
   (linear-layout
459
    (make-id "") 'vertical fillwrap trans-col
460
    (list
461
     (mtitle "pf-details" "Pack: xxx Pup: xxx")))
462
463
464
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
465
466
467
468
469
470
     (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"))
                     )))
471
472
473
474
475
476
477
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


  (fragment
478
   "events"
479
   (linear-layout
480
    0 'vertical fillwrap trans-col
481
    (list
482
     (linear-layout
Dave Griffiths's avatar
Dave Griffiths committed
483
      (make-id "ev-pf") 'vertical fill pf-col
484
      (list
485
486
       (mtitle "ev-pf-text" "Pup Focal Events")
       (horiz
Dave Griffiths's avatar
Dave Griffiths committed
487
488
489
490
        (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")))))))
491
     (linear-layout
492
      (make-id "ev-pf") 'vertical fill gp-col
493
      (list
494
495
       (mtitle "text" "Group Events")
       (horiz
Dave Griffiths's avatar
Dave Griffiths committed
496
497
498
        (mbutton2 "evb-grpint" "Interaction" (lambda () (list (replace-fragment (get-id "event-holder") "ev-grpint"))))
        (mbutton2 "evb-grpalarm" "Alarm" (lambda () (list (replace-fragment (get-id "event-holder") "ev-grpalarm"))))
        (mbutton2 "evb-grpmov" "Movement" (lambda () (list (replace-fragment (get-id "event-holder") "ev-grpmov")))))))))
499
500
501
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
502
     (if (equal? (get-current 'observation "none") obs-pf)
503
504
         (list
          (update-widget 'text-view (get-id "ev-pf-text") 'show 0)
Dave Griffiths's avatar
Dave Griffiths committed
505
506
507
508
          (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))))
509
510
511
512
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))
513

514
515
516
  (fragment
   "pf-scan1"
   (linear-layout
517
    (make-id "") 'vertical fillwrap pf-col
518
    (list
519
520
521
     (mtext "title" "Nearest Neighbour Scan")
     (build-grid-selector "pf-scan-nearest" "single" "Closest Mongoose")
     (build-grid-selector "pf-scan-close" "toggle" "Mongooses within 2m")
522
523
524
525
     (mbutton "pf-scan-done" "Done"
              (lambda ()
                (entity-add-value! "parent" "varchar" (get-current 'pup-focal-id ""))
                (entity-record-values db "stream" "pup-focal-nearest")
526
                (list (replace-fragment (get-id "pf-top") "pf-timer"))))))
527
528
529
530

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
531
532
     (list
      (populate-grid-selector
533
       "pf-scan-nearest" "single"
534
535
       (db-all-where db "sync" "mongoose"
                     (list "pack-id" (ktv-get (get-current 'pack '()) "unique_id")))
536
537
       (lambda (individual)
         (entity-add-value! "id-nearest" "varchar" (ktv-get individual "unique_id"))
538
539
         (list)))
      (populate-grid-selector
540
       "pf-scan-close" "toggle"
541
542
       (db-all-where db "sync" "mongoose"
                     (list "pack-id" (ktv-get (get-current 'pack '()) "unique_id")))
543
544
       (lambda (individuals)
         (entity-add-value! "id-list-close" "varchar" (assemble-array individuals))
545
546
         (list)))
      ))
547
548
549
550
551
552
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


553
554
555
  (fragment
   "ev-pupfeed"
   (linear-layout
556
    (make-id "") 'vertical fillwrap pf-col
557
    (list
558
     (mtitle "title" "Event: Pup is fed")
559
560
561
     (build-grid-selector "pf-pupfeed-who" "single" "Who fed the pup?")
     (mtext "text" "Food size")
     (horiz
562
563
564
565
566
567
568
      (spinner (make-id "pf-pupfeed-size") (list "Small" "Medium" "Large") fillwrap
               (lambda (v)
                 (entity-add-value! "size" "varchar" v) '()))
      (mbutton "pf-pupfeed-done" "Done"
               (lambda ()
                 (entity-add-value! "parent" "varchar" (get-current 'pup-focal-id ""))
                 (entity-record-values db "stream" "pup-focal-pupfeed")
Dave Griffiths's avatar
Dave Griffiths committed
569
                 (list (replace-fragment (get-id "event-holder") "events")))))))
570
571
572
573
574
575
576
577
578
579

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
      (populate-grid-selector
       "pf-pupfeed-who" "single"
       (db-all-where db "sync" "mongoose"
                     (list "pack-id" (ktv-get (get-current 'pack '()) "unique_id")))
       (lambda (individual)
580
         (entity-add-value! "id-who" "varchar" (ktv-get individual "unique_id"))
581
582
583
584
585
586
587
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

Dave Griffiths's avatar
Dave Griffiths committed
588
589
590
  (fragment
   "ev-pupfind"
   (linear-layout
591
    (make-id "") 'vertical fillwrap pf-col
Dave Griffiths's avatar
Dave Griffiths committed
592
    (list
593
     (mtitle "title" "Event: Pup found food")
Dave Griffiths's avatar
Dave Griffiths committed
594
595
     (mtext "text" "Food size")
     (horiz
596
597
598
599
600
601
      (spinner (make-id "pf-pupfind-size") (list "Small" "Medium" "Large") fillwrap
               (lambda (v) (entity-add-value! "size" "varchar" v) '()))
      (mbutton "pf-pupfind-done" "Done"
               (lambda ()
                 (entity-add-value! "parent" "varchar" (get-current 'pup-focal-id ""))
                 (entity-record-values db "stream" "pup-focal-pupfind")
Dave Griffiths's avatar
Dave Griffiths committed
602
                 (list (replace-fragment (get-id "event-holder") "events")))))))
Dave Griffiths's avatar
Dave Griffiths committed
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


  (fragment
   "ev-pupcare"
   (linear-layout
618
    (make-id "") 'vertical fillwrap pf-col
Dave Griffiths's avatar
Dave Griffiths committed
619
    (list
620
     (mtitle "title" "Event: Pup is cared for")
Dave Griffiths's avatar
Dave Griffiths committed
621
622
623
     (build-grid-selector "pf-pupcare-who" "single" "Who cared for the pup?")
     (mtext "text" "Type of care")
     (horiz
624
625
626
627
628
629
630
      (spinner (make-id "pf-pupcare-type") (list "Carry" "Lead" "Sniff" "Play" "Ano-genital sniff") fillwrap
               (lambda (v)
                 (entity-add-value! "type" "varchar" v) '()))
      (mbutton "pf-pupcare-done" "Done"
               (lambda ()
                 (entity-add-value! "parent" "varchar" (get-current 'pup-focal-id ""))
                 (entity-record-values db "stream" "pup-focal-pupcare")
Dave Griffiths's avatar
Dave Griffiths committed
631
                 (list (replace-fragment (get-id "event-holder") "events")))))))
Dave Griffiths's avatar
Dave Griffiths committed
632
633
634
635
636
637
638
639
640
641

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
      (populate-grid-selector
       "pf-pupcare-who" "single"
       (db-all-where db "sync" "mongoose"
                     (list "pack-id" (ktv-get (get-current 'pack '()) "unique_id")))
       (lambda (individual)
642
         (entity-add-value! "id-who" "varchar" (ktv-get individual "unique_id"))
Dave Griffiths's avatar
Dave Griffiths committed
643
644
645
646
647
648
649
650
651
652
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "ev-pupaggr"
   (linear-layout
653
    (make-id "") 'vertical fillwrap pf-col
Dave Griffiths's avatar
Dave Griffiths committed
654
    (list
655
     (mtitle "title" "Event: Pup aggression")
Dave Griffiths's avatar
Dave Griffiths committed
656
657
658
     (build-grid-selector "pf-pupaggr-partner" "single" "Aggressive mongoose")

     (linear-layout
659
      (make-id "") 'horizontal (layout 'fill-parent 100 '1 'left 0) trans-col
Dave Griffiths's avatar
Dave Griffiths committed
660
661
662
      (list
       (vert
        (mtext "" "Fighting over")
663
664
665
        (spinner (make-id "pf-pupaggr-over") (list "Food" "Escort" "Nothing" "Other") fillwrap
                 (lambda (v)
                   (entity-add-value! "over" "varchar" v) '())))
Dave Griffiths's avatar
Dave Griffiths committed
666
667
       (vert
        (mtext "" "Level")
668
669
670
671
672
        (spinner (make-id "pf-pupaggr-level") (list "Block" "Snap" "Chase" "Push" "Fight") fillwrap
                 (lambda (v)
                   (entity-add-value! "level" "varchar" v) '())))
       (mtoggle-button "pf-pupaggr-in" "Initiate?"
                       (lambda (v)
673
                         (entity-add-value! "initiate" "varchar" (if v "yes" "no")) '()))
674
675
       (mtoggle-button "pf-pupaggr-win" "Win?"
                       (lambda (v)
676
                         (entity-add-value! "win" "varchar" (if v "yes" "no")) '()))))
677
678
679
680
     (mbutton "pf-pupaggr-done" "Done"
              (lambda ()
                (entity-add-value! "parent" "varchar" (get-current 'pup-focal-id ""))
                (entity-record-values db "stream" "pup-focal-pupaggr")
Dave Griffiths's avatar
Dave Griffiths committed
681
                (list (replace-fragment (get-id "event-holder") "events"))))))
Dave Griffiths's avatar
Dave Griffiths committed
682
683
684
685
686
687
688
689
690
691

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
      (populate-grid-selector
       "pf-pupaggr-partner" "single"
       (db-all-where db "sync" "mongoose"
                     (list "pack-id" (ktv-get (get-current 'pack '()) "unique_id")))
       (lambda (individual)
692
         (entity-add-value! "id-with" "varchar" (ktv-get individual "unique_id"))
Dave Griffiths's avatar
Dave Griffiths committed
693
694
695
696
697
698
699
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

700
701
702
703
704
705
706
707
708
709
710
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (fragment
   "ev-grpint"
   (linear-layout
    (make-id "") 'vertical fillwrap gp-col
    (list
     (mtitle "title" "Event: Group Interaction")
     (build-grid-selector "gp-int-pack" "single" "Inter-group interaction: Other pack identity")
     (build-grid-selector "gp-int-leader" "single" "Leader")
     (linear-layout
711
      (make-id "") 'horizontal (layout 'fill-parent 80 '1 'left 0) trans-col
712
713
714
      (list
       (vert
        (mtext "text" "Outcome")
715
716
717
        (spinner (make-id "gp-int-out") (list "Retreat" "Advance" "Fight & retreat" "Fight & win") fillwrap
                 (lambda (v)
                   (entity-add-value! "outcome" "varchar" v) '())))
718
719
       (vert
        (mtext "text" "Duration")
720
721
722
723
724
        (edit-text (make-id "gp-int-dur") "" 20 "numeric" fillwrap
                   (lambda (v) (entity-add-value! "duration" "int" (string->number v)) '())))
       (mbutton "pf-grpint-done" "Done"
                (lambda ()
                  (entity-record-values db "stream" "group-interaction")
Dave Griffiths's avatar
Dave Griffiths committed
725
                  (list (replace-fragment (get-id "event-holder") "events"))))))))
726
727
728
729
730
731
732
733

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
      (populate-grid-selector
       "gp-int-pack" "single"
       (db-all db "sync" "pack")
734
735
       (lambda (pack)
         (entity-add-value! "id-other-pack" "varchar" (ktv-get pack "unique_id"))
736
737
738
739
740
741
         (list)))
      (populate-grid-selector
       "gp-int-leader" "single"
       (db-all-where db "sync" "mongoose"
                     (list "pack-id" (ktv-get (get-current 'pack '()) "unique_id")))
       (lambda (individual)
742
         (entity-add-value! "id-leader" "varchar" (ktv-get individual "unique_id"))
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


  (fragment
   "ev-grpalarm"
   (linear-layout
    (make-id "") 'vertical fillwrap gp-col
    (list
     (mtitle "title" "Event: Group alarm")
     (build-grid-selector "gp-alarm-caller" "single" "Alarm caller")
     (mtext "text" "Cause")
     (horiz
760
761
762
763
764
765
766
767
768
769
      (spinner (make-id "gp-alarm-cause") (list "Predator" "Other mongoose pack" "Humans" "Other" "Unknown") fillwrap
               (lambda (v)
                 (entity-add-value! "cause" "varchar" v) '()))
      (mtoggle-button "gp-alarm-join" "Did the others join in?"
                      (lambda (v)
                        (entity-add-value! "others-join" "varchar"
                                           (if v "yes" "no")) '())))
     (mbutton "pf-grpalarm-done" "Done"
              (lambda ()
                (entity-record-values db "stream" "group-alarm")
Dave Griffiths's avatar
Dave Griffiths committed
770
                (list (replace-fragment (get-id "event-holder") "events"))))))
771
772
773
774
775
776
777
778
779
780

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
      (populate-grid-selector
       "gp-alarm-caller" "single"
       (db-all-where db "sync" "mongoose"
                     (list "pack-id" (ktv-get (get-current 'pack '()) "unique_id")))
       (lambda (individual)
781
         (entity-add-value! "id-caller" "varchar" (ktv-get individual "unique_id"))
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "ev-grpmov"
   (linear-layout
    (make-id "") 'vertical fillwrap gp-col
    (list
     (mtitle "title" "Event: Group movement")
     (build-grid-selector "gp-mov-leader" "single" "Leader")
     (linear-layout
797
      (make-id "") 'horizontal (layout 'fill-parent 90 '1 'left 0) trans-col
798
      (list
799
800
801
802
803
804
       (medit-text "gp-mov-w" "Width" "numeric"
                   (lambda (v) (entity-add-value! "pack-width" "int" (string->number v)) '()))
       (medit-text "gp-mov-l" "Length" "numeric"
                   (lambda (v) (entity-add-value! "pack-height" "int" (string->number v)) '()))
       (medit-text "gp-mov-l" "How many" "numeric"
                   (lambda (v) (entity-add-value! "pack-count" "int" (string->number v)) '()))))
805
     (linear-layout
806
      (make-id "") 'horizontal (layout 'fill-parent 90 '1 'left 0) trans-col
807
808
809
      (list
       (vert
        (mtext "" "Where to")
810
811
812
813
814
        (spinner (make-id "gp-mov-to") (list "Latrine" "Water" "Food" "Nothing" "Unknown") fillwrap
                 (lambda (v) (entity-add-value! "destination" "varchar" v)  '())))
       (mbutton "pf-grpmov-done" "Done"
                (lambda ()
                  (entity-record-values db "stream" "group-move")
Dave Griffiths's avatar
Dave Griffiths committed
815
                  (list (replace-fragment (get-id "event-holder") "events"))))))))
816
817
818
819
820
821
822
823
824
825

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
      (populate-grid-selector
       "gp-mov-leader" "single"
       (db-all-where db "sync" "mongoose"
                     (list "pack-id" (ktv-get (get-current 'pack '()) "unique_id")))
       (lambda (individual)
826
         (entity-add-value! "id-leader" "varchar" (ktv-get individual "unique_id"))
827
828
829
830
831
832
833
834
835
836
837
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))



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

838
839


840

Dave Griffiths's avatar
Dave Griffiths committed
841
  (fragment
842
   "gc-start"
843
   (linear-layout
844
    (make-id "") 'vertical fillwrap gc-col
845
846
847
848
849
    (list
     (mtitle "title" "Start")
     (mtoggle-button "gc-start-main-obs" "Main observer" (lambda (v) '()))
     (mtext "" "Code")
     (edit-text (make-id "gc-start-code") "" 20 "numeric" fillwrap (lambda (v) '()))
850
     (build-grid-selector "gc-start-present" "toggle" "Who's present?")))
851
852
853
854
855
856

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
      (populate-grid-selector
857
       "gc-start-present" "toggle"
858
859
860
861
862
863
864
865
866
867
868
869
870
       (db-all-where db "sync" "mongoose"
                     (list "pack-id" (ktv-get (get-current 'pack '()) "unique_id")))
       (lambda (individual)
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "gc-weights"
   (linear-layout
871
    (make-id "") 'vertical fillwrap gc-col
872
873
    (list
     (mtitle "title" "Weights")
874
     (build-grid-selector "gc-weigh-choose" "toggle" "Choose mongoose")
875
     (edit-text (make-id "gc-weigh-weight") "" 20 "numeric" fillwrap (lambda (v) '()))
876
     (mtoggle-button "gc-weigh-accurate" "Accurate?" (lambda (v) '()))))
877
878
879
880
881
882

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
      (populate-grid-selector
883
       "gc-weigh-choose" "toggle"
884
885
886
887
888
889
890
891
892
893
894
895
896
897
       (db-all-where
        db "sync" "mongoose"
        (list "pack-id" (ktv-get (get-current 'pack '()) "unique_id")))
       (lambda (individual)
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "gc-preg"
   (linear-layout
898
    (make-id "") 'vertical fillwrap gc-col
899
900
    (list
     (mtitle "title" "Pregnant females")
901
     (build-grid-selector "gc-preg-choose" "toggle" "Choose")))
902
903
904
905
906

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
907
908
      (populate-grid-selector
       "gc-preg-choose" "toggle"
909
910
911
912
913
914
915
916
917
918
919
       (db-all-where
        db "sync" "mongoose"
        (list "pack-id" (ktv-get (get-current 'pack '()) "unique_id")))
       (lambda (individual)
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

920

921
922
923
  (fragment
   "gc-pup-assoc"
   (linear-layout
924
    (make-id "") 'vertical fillwrap gc-col
925
    (list
926
     (mtitle "title" "Pup Associations")
927
928
     (build-grid-selector "gc-pup-choose" "toggle" "Choose pup")
     (build-grid-selector "gc-pup-escort" "toggle" "Escort")))
929
930
931
932
933

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
934
935
      (populate-grid-selector
       "gc-pup-choose" "toggle"
936
937
938
939
940
       (db-all-where
        db "sync" "mongoose"
        (list "pack-id" (ktv-get (get-current 'pack '()) "unique_id")))
       (lambda (individual)
         (list)))
941
942
      (populate-grid-selector
       "gc-pup-escort" "toggle"
943
944
945
946
947
948
949
950
951
952
953
954
955
956
       (db-all-where
        db "sync" "mongoose"
        (list "pack-id" (ktv-get (get-current 'pack '()) "unique_id")))
       (lambda (individual)
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "gc-oestrus"
   (linear-layout
957
    (make-id "") 'vertical fillwrap gc-col
958
959
960
961
962
963
964
965
966
967
968
969
970
971
    (list
     (mtext "" "Oestrus...")))
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "gc-babysitting"
   (linear-layout
972
    (make-id "") 'vertical fillwrap gc-col
973
974
975
976
977
978
979
980
981
982
    (list
     (mtext "" "Babysittings...")))
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))
983

984
985
986
  (fragment
   "gc-end"
   (linear-layout
987
    (make-id "") 'vertical fillwrap gc-col
988
989
    (list
     (mtext "" "end!...")))
Dave Griffiths's avatar
Dave Griffiths committed
990
991
   (lambda (fragment arg)
     (activity-layout fragment))
992
993
   (lambda (fragment arg)
     (list))
Dave Griffiths's avatar
Dave Griffiths committed
994
995
996
997
998
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

999
1000


Dave Griffiths's avatar
Dave Griffiths committed
1001
1002
  )

1003
1004
1005
1006
(msg "one")

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

1008
(define-activity-list
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
;  (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) '()))
1027

Dave Griffiths's avatar
Dave Griffiths committed
1028

1029
1030
1031
  (activity
   "main"
   (vert
Dave Griffiths's avatar
Dave Griffiths committed
1032
1033
    (text-view (make-id "main-title") "Mongoose 2000" 40 fillwrap)
    (text-view (make-id "main-about") "Advanced mongoose technology" 20 fillwrap)
1034
    (spacer 10)
1035
1036
1037
1038
    (horiz
     (mbutton2 "main-observations" "Observations" (lambda () (list (start-activity "observations" 2 ""))))
     (mbutton2 "main-manage" "Manage Packs" (lambda () (list (start-activity "manage-packs" 2 ""))))
     (mbutton2 "main-tag" "Tag Location" (lambda () (list (start-activity "tag-location" 2 "")))))
1039
    (mtext "foo" "Your ID")
Dave Griffiths's avatar
Dave Griffiths committed
1040
    (edit-text (make-id "main-id-text") "" 30 "text" fillwrap
1041
1042
1043
1044
               (lambda (v)
                 (set-current! 'user-id v)
                 (update-entity
                  db "local" 1 (list (ktv "user-id" "varchar" v)))))
Dave Griffiths's avatar
Dave Griffiths committed
1045
1046
    (mtext "foo" "Database")
    (horiz
1047
1048
     (mbutton2 "main-send" "Email" (lambda () (list)))
     (mbutton2 "main-sync" "Sync" (lambda () (list (start-activity "sync" 0 ""))))))
Dave Griffiths's avatar
Dave Griffiths committed
1049
1050
   (lambda (activity arg)
     (activity-layout activity))
1051
1052
1053
1054
1055
   (lambda (activity arg)
     (let ((user-id (ktv-get (get-entity db "local" 1) "user-id")))
       (set-current! 'user-id user-id)
       (list
        (update-widget 'edit-text (get-id "main-id-text") 'text user-id))))
Dave Griffiths's avatar
Dave Griffiths committed
1056
1057
1058
1059
1060
1061
1062
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity requestcode resultcode) '()))

  (activity
1063
   "observations"
Dave Griffiths's avatar
Dave Griffiths committed
1064
   (vert
1065
1066
1067
    (text-view (make-id "title") "Start Observation" 40 fillwrap)
    (vert
     (mtext "type" "Choose observation type")
1068
     (horiz
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
      (linear-layout
       0 'vertical wrap gc-col
       (list
        (mtoggle-button2 "choose-obs-gc" obs-gc
                         (lambda (v)
                           (set-current! 'observation obs-gc)
                           (mclear-toggles (list "choose-obs-pf" "choose-obs-gp"))))))
      (linear-layout
       0 'vertical wrap pf-col
       (list
        (mtoggle-button2 "choose-obs-pf" obs-pf
                         (lambda (v)
                           (set-current! 'observation obs-pf)
                           (mclear-toggles (list "choose-obs-gc" "choose-obs-gp"))))))
      (linear-layout
       0 'vertical wrap gp-col
       (list
        (mtoggle-button2 "choose-obs-gp" obs-gp
                         (lambda (v)
                           (set-current! 'observation obs-gp)
                           (mclear-toggles (list "choose-obs-pf" "choose-obs-gc"))))))))
1090
    (build-grid-selector "choose-obs-pack-selector" "single" "Choose pack")
1091
1092
1093
    (mbutton
     "choose-obs-start" "Start"
     (lambda ()
1094
1095
1096
1097
1098
1099
1100
       ;; set up the observation fragments
       (let ((obs (get-current 'observation "none")))
         (when (not (equal? obs "none"))
           (set-current!
            'observation-fragments
            (cond
             ((equal? obs obs-gc) gc-fragments)
1101
             (else '())))))
1102
1103

       ;; go to observation
1104
1105
       (if (and (current-exists? 'pack)
                (current-exists? 'observation))
1106
1107
           (cond
            ((eq? (get-current 'observation "none") obs-pf)
1108
             (list (start-activity "pup-focal-start" 2 "")))
1109
            ((eq? (get-current 'observation "none") obs-gp)
1110
             (list (start-activity "group-events" 2 "")))
1111
            (else
1112
             (list (start-activity "group-composition" 2 ""))))
1113
1114
1115
1116
1117
           (list
            (alert-dialog
             "choose-obs-finish"
             "Need to specify a pack and an observation"
             (lambda () '()))))))
Dave Griffiths's avatar
Dave Griffiths committed
1118
1119
1120
    )
   (lambda (activity arg)
     (activity-layout activity))
1121
1122
   (lambda (activity arg)
     (list
1123
1124
1125
      (populate-grid-selector
       "choose-obs-pack-selector" "single"
       (db-all db "sync" "pack")
1126
       (lambda (pack)
1127
1128
1129
         (msg "in selector" pack)
         (set-current! 'pack pack)
         '()))))
Dave Griffiths's avatar
Dave Griffiths committed
1130
1131
1132
1133
1134
1135
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity requestcode resultcode) '()))

1136

Dave Griffiths's avatar
Dave Griffiths committed
1137
  (activity
1138
   "group-composition"
Dave Griffiths's avatar
Dave Griffiths committed
1139
1140
1141
1142
1143
1144
1145
1146
1147
    (linear-layout
     0 'vertical fillwrap gc-bgcol
     (list
      (text-view (make-id "obs-title") "" 40 fillwrap)
      (linear-layout
       (make-id "obs-buttons-bar") 'horizontal fillwrap trans-col '())
      (build-fragment "gc-start" (make-id "gc-top") (layout 595 400 1 'left 0))
      (build-fragment "events" (make-id "event-holder") (layout 595 450 1 'left 0))
      (mbutton "gc-done" "Done" (lambda () (list (finish-activity 0))))))
Dave Griffiths's avatar
Dave Griffiths committed
1148
1149
   (lambda (activity arg)
     (activity-layout activity))
1150
   (lambda (activity arg)
1151
     (msg (get-current 'observation-fragments '()))
1152
     (list
1153
1154
1155
1156
1157
1158
1159
      (update-widget 'linear-layout (get-id "obs-buttons-bar") 'contents
                     (let ((all-toggles
                            (map
                             (lambda (i) (string-append "obs-bar-" (cadr i)))
                             (get-current 'observation-fragments '()))))
                       (map
                        (lambda (frag)
1160
                          (msg "button-bar" frag)
1161
1162
1163
1164
1165
1166
1167
                          (let ((id (string-append "obs-bar-" (cadr frag))))
                            (toggle-button
                             (make-id id) (car frag) 12 fillwrap
                             (lambda (v)
                               (append
                                (mclear-toggles-not-me id all-toggles)
                                (list
Dave Griffiths's avatar
Dave Griffiths committed
1168
                                 (replace-fragment (get-id "gc-top") (cadr frag))))))))
1169
                        (get-current 'observation-fragments '()))))
1170
1171
1172
1173
      (update-widget 'text-view (get-id "obs-title") 'text
                     (string-append
                      (get-current 'observation "No observation")
                      " with " (ktv-get (get-current 'pack '()) "name")))
1174
      ))
Dave Griffiths's avatar
Dave Griffiths committed
1175
1176
1177
1178
1179
1180
1181
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity requestcode resultcode) '()))

  (activity
1182
   "pup-focal-start"
1183
   (linear-layout
1184
    0 'vertical fillwrap pf-bgcol
1185
1186
1187
1188
1189
1190
    (list
     (vert
      (mtitle "" "Pup focal setup")
      (mtext "pf1-pack" "Pack")
      (build-grid-selector "pf1-grid" "single" "Select pup")
      (horiz
1191
1192
1193
1194
1195
1196
       (medit-text "pf1-width" "Pack width" "numeric"
                   (lambda (v) (entity-add-value! "pack-width" "int" v) '()))
       (medit-text "pf1-height" "Pack height" "numeric"
                   (lambda (v) (entity-add-value! "pack-height" "int" v) '())))
      (medit-text "pf1-count" "How many mongooses present?" "numeric"
                  (lambda (v) (entity-add-value! "pack-count" "int" v) '()))
1197
1198
      (mbutton "pf1-done" "Done"
               (lambda ()
1199
                 (set-current! 'pup-focal-id (entity-record-values db "stream" "pup-focal"))
Dave Griffiths's avatar
Dave Griffiths committed
1200
1201
                 (set-current! 'timer-minutes 20)
                 (set-current! 'timer-seconds 59)
1202
1203
                 (list
                  (start-activity "pup-focal" 2 ""))))
1204
      )))
Dave Griffiths's avatar
Dave Griffiths committed
1205
1206
   (lambda (activity arg)
     (activity-layout activity))
1207
1208
   (lambda (activity arg)
     (list
1209
1210
1211
1212
      (populate-grid-selector
       "pf1-grid" "single"
       (db-all-where db "sync" "mongoose" (list "pack-id" (ktv-get (get-current 'pack '()) "unique_id")))
       (lambda (individual)
1213
         (set-current! 'individual individual)
1214
         (entity-add-value! "id-focal-subject" "varchar" (ktv-get individual "unique_id"))
1215
         '()))))
Dave Griffiths's avatar
Dave Griffiths committed
1216
1217
1218
1219
1220
1221
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity requestcode resultcode) '()))

1222

Dave Griffiths's avatar
Dave Griffiths committed
1223
  (activity
1224
   "pup-focal"
1225
    (linear-layout
1226
     0 'vertical fillwrap pf-bgcol
1227
     (list
1228
1229
      (horiz
       (mtitle "title" "Pup Focal")
Dave Griffiths's avatar
Dave Griffiths committed
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
       (linear-layout
        0 'vertical fillwrap trans-col
        (list
         (mtext "title" "Time left:")
         (mtitle "pf-timer-time-minutes"
                 (number->string (get-current 'timer-minutes 20)))))
       (linear-layout
        0 'vertical fillwrap trans-col
        (list
         (mtext "title" "Next scan:")
         (mtitle "pf-timer-time"
                 (number->string (get-current 'timer-seconds 60)))))
1242
1243
1244
1245
1246
1247
       (mtoggle-button "pf-pause" "Pause"
                       (lambda (v)
                         (msg "pausing")
                         (if v
                             (list (delayed "timer" 1000 (lambda () '())))
                             (list (delayed "timer" 1000 timer-cb))))))