starwisp.scm 53.3 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
;; Starwisp Copyright (C) 2013 Dave Griffiths
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU Affero General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

16
17
18
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
223
224
   (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)
        (display v)(newline)
        (if (equal? (car v) "inserted")
Dave Griffiths's avatar
Dave Griffiths committed
225
226
227
228
            (begin
              (update-entity-clean db table (cadr v))
              (toast "Uploaded " (ktv-get (cadr e) "name")))
            (toast "Problem uploading " (ktv-get (cadr e) "name"))))))
229
   (dirty-entities db table)))
Dave Griffiths's avatar
Dave Griffiths committed
230

231
(define (suck-entity-from-server db table unique-id exists)
Dave Griffiths's avatar
Dave Griffiths committed
232
233
234
235
236
237
238
  ;; 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'
239
240
     (let ((entity (list-ref data 0))
           (ktvlist (list-ref data 1)))
Dave Griffiths's avatar
Dave Griffiths committed
241
       (if (not exists)
242
243
244
245
246
247
248
249
           (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
250
251
           (update-to-version
            db table (get-entity-id db table unique-id)
Dave Griffiths's avatar
Dave Griffiths committed
252
253
254
255
            (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
256

Dave Griffiths's avatar
Dave Griffiths committed
257
;; repeatedly read version and request updates
Dave Griffiths's avatar
Dave Griffiths committed
258
(define (suck-new db table)
Dave Griffiths's avatar
Dave Griffiths committed
259
260
261
  (list
   (http-request
    "new-entities-req"
262
    (string-append url "fn=entity-versions&table=" table)
Dave Griffiths's avatar
Dave Griffiths committed
263
    (lambda (data)
Dave Griffiths's avatar
Dave Griffiths committed
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
      (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
284

285
286
287
288
289
290
291
292
293
(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
294
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
295
;; user interface abstraction
Dave Griffiths's avatar
Dave Griffiths committed
296

Dave Griffiths's avatar
Dave Griffiths committed
297
298
299
(define (mbutton id title fn)
  (button (make-id id) title 20 fillwrap fn))

300
(define (mbutton2 id title fn)
301
  (button (make-id id) title 20 (layout 150 100 1 'centre 0) fn))
302

303
304
305
(define (mtoggle-button id title fn)
  (toggle-button (make-id id) title 20 fillwrap fn))

306
(define (mtoggle-button2 id title fn)
307
  (toggle-button (make-id id) title 20 (layout 150 100 1 'centre 0) fn))
308

Dave Griffiths's avatar
Dave Griffiths committed
309
310
(define (mtext id text)
  (text-view (make-id id) text 20 fillwrap))
311

312
313
314
(define (mtitle id text)
  (text-view (make-id id) text 40 fillwrap))

315
316
(define (medit-text id text type fn)
  (vert
317
318
   (mtext (string-append id "-title") text)
   (edit-text (make-id id) "" 20 type fillwrap fn)))
319
320
321
322
323
324
325

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

326
327
328
329
330
331
332
(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))

333
334
335
336
337
338
339
340
341
342
(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))

343
344
;;;;

345
(define (build-grid-selector name type title)
346
  (vert
347
   (mtext "title" title)
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
   (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))))))
364

365
;; assumes grid selectors on mongeese only
366
367
368
(define (fast-get-name item)
  (list-ref (list-ref item 1) 2))

369
370
371
372
373
374
375
376
377
(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))

378
379
380
(define (populate-grid-selector name type items fn)
  (let ((id->items (build-button-items name items))
        (selected-set '()))
381
382
383
    (update-widget
     'button-grid (get-id name) 'grid-buttons
     (list
384
      type 3 20 (layout 100 40 1 'left 0)
385
386
387
388
      (map
       (lambda (ii)
         (list (car ii) (caddr ii)))
       id->items)
389
390
      (lambda (v state)
        (cond
391
392
         ((equal? type "toggle")
          ;; update list of selected items
393
394
395
396
397
398
399
400
401
402
          (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))
403
404
          (fn (cadr (findv v id->items))))))))))

405
406
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
Dave Griffiths's avatar
Dave Griffiths committed
407

408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
(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))))
    )))

430
431
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; fragments
Dave Griffiths's avatar
Dave Griffiths committed
432
433
434

(define-fragment-list

435
436
437
  (fragment
   "pf-timer"
   (linear-layout
438
    (make-id "") 'vertical fillwrap trans-col
439
    (list
440
     (mtitle "pf-details" "Pack: xxx Pup: xxx")))
441
442
443
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
444
445
446
447
448
449
     (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"))
                     )))
450
451
452
453
454
455
456
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


  (fragment
457
   "events"
458
   (linear-layout
459
    0 'vertical fillwrap trans-col
460
    (list
461
     (linear-layout
462
      (make-id "ev-pf") 'vertical wrapfill pf-col
463
      (list
464
465
       (mtitle "ev-pf-text" "Pup Focal Events")
       (horiz
Dave Griffiths's avatar
Dave Griffiths committed
466
467
468
469
        (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")))))))
470
     (linear-layout
471
      (make-id "ev-pf") 'vertical fill gp-col
472
      (list
473
474
       (mtitle "text" "Group Events")
       (horiz
Dave Griffiths's avatar
Dave Griffiths committed
475
476
477
        (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")))))))))
478
479
480
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
481
     (if (equal? (get-current 'observation "none") obs-pf)
482
483
         (list
          (update-widget 'text-view (get-id "ev-pf-text") 'show 0)
Dave Griffiths's avatar
Dave Griffiths committed
484
485
486
487
          (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))))
488
489
490
491
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))
492

493
494
495
  (fragment
   "pf-scan1"
   (linear-layout
496
    (make-id "") 'vertical fillwrap pf-col
497
    (list
498
499
500
     (mtext "title" "Nearest Neighbour Scan")
     (build-grid-selector "pf-scan-nearest" "single" "Closest Mongoose")
     (build-grid-selector "pf-scan-close" "toggle" "Mongooses within 2m")
501
502
503
504
     (mbutton "pf-scan-done" "Done"
              (lambda ()
                (entity-add-value! "parent" "varchar" (get-current 'pup-focal-id ""))
                (entity-record-values db "stream" "pup-focal-nearest")
505
                (list (replace-fragment (get-id "pf-top") "pf-timer"))))))
506
507
508
509

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
510
511
     (list
      (populate-grid-selector
512
       "pf-scan-nearest" "single"
513
514
       (db-all-where db "sync" "mongoose"
                     (list "pack-id" (ktv-get (get-current 'pack '()) "unique_id")))
515
516
       (lambda (individual)
         (entity-add-value! "id-nearest" "varchar" (ktv-get individual "unique_id"))
517
518
         (list)))
      (populate-grid-selector
519
       "pf-scan-close" "toggle"
520
521
       (db-all-where db "sync" "mongoose"
                     (list "pack-id" (ktv-get (get-current 'pack '()) "unique_id")))
522
523
       (lambda (individuals)
         (entity-add-value! "id-list-close" "varchar" (assemble-array individuals))
524
525
         (list)))
      ))
526
527
528
529
530
531
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


532
533
534
  (fragment
   "ev-pupfeed"
   (linear-layout
535
    (make-id "") 'vertical fillwrap pf-col
536
    (list
537
     (mtitle "title" "Event: Pup is fed")
538
539
540
     (build-grid-selector "pf-pupfeed-who" "single" "Who fed the pup?")
     (mtext "text" "Food size")
     (horiz
541
542
543
544
545
546
547
      (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
548
                 (list (replace-fragment (get-id "event-holder") "events")))))))
549
550
551
552
553
554
555
556
557
558

   (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)
559
         (entity-add-value! "id-who" "varchar" (ktv-get individual "unique_id"))
560
561
562
563
564
565
566
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

Dave Griffiths's avatar
Dave Griffiths committed
567
568
569
  (fragment
   "ev-pupfind"
   (linear-layout
570
    (make-id "") 'vertical fillwrap pf-col
Dave Griffiths's avatar
Dave Griffiths committed
571
    (list
572
     (mtitle "title" "Event: Pup found food")
Dave Griffiths's avatar
Dave Griffiths committed
573
574
     (mtext "text" "Food size")
     (horiz
575
576
577
578
579
580
      (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
581
                 (list (replace-fragment (get-id "event-holder") "events")))))))
Dave Griffiths's avatar
Dave Griffiths committed
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596

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


  (fragment
   "ev-pupcare"
   (linear-layout
597
    (make-id "") 'vertical fillwrap pf-col
Dave Griffiths's avatar
Dave Griffiths committed
598
    (list
599
     (mtitle "title" "Event: Pup is cared for")
Dave Griffiths's avatar
Dave Griffiths committed
600
601
602
     (build-grid-selector "pf-pupcare-who" "single" "Who cared for the pup?")
     (mtext "text" "Type of care")
     (horiz
603
604
605
606
607
608
609
      (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
610
                 (list (replace-fragment (get-id "event-holder") "events")))))))
Dave Griffiths's avatar
Dave Griffiths committed
611
612
613
614
615
616
617
618
619
620

   (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)
621
         (entity-add-value! "id-who" "varchar" (ktv-get individual "unique_id"))
Dave Griffiths's avatar
Dave Griffiths committed
622
623
624
625
626
627
628
629
630
631
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "ev-pupaggr"
   (linear-layout
632
    (make-id "") 'vertical fillwrap pf-col
Dave Griffiths's avatar
Dave Griffiths committed
633
    (list
634
     (mtitle "title" "Event: Pup aggression")
Dave Griffiths's avatar
Dave Griffiths committed
635
636
637
     (build-grid-selector "pf-pupaggr-partner" "single" "Aggressive mongoose")

     (linear-layout
638
      (make-id "") 'horizontal (layout 'fill-parent 100 '1 'left 0) trans-col
Dave Griffiths's avatar
Dave Griffiths committed
639
640
641
      (list
       (vert
        (mtext "" "Fighting over")
642
643
644
        (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
645
646
       (vert
        (mtext "" "Level")
647
648
649
650
651
        (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)
652
                         (entity-add-value! "initiate" "varchar" (if v "yes" "no")) '()))
653
654
       (mtoggle-button "pf-pupaggr-win" "Win?"
                       (lambda (v)
655
                         (entity-add-value! "win" "varchar" (if v "yes" "no")) '()))))
656
657
658
659
     (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
660
                (list (replace-fragment (get-id "event-holder") "events"))))))
Dave Griffiths's avatar
Dave Griffiths committed
661
662
663
664
665
666
667
668
669
670

   (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)
671
         (entity-add-value! "id-with" "varchar" (ktv-get individual "unique_id"))
Dave Griffiths's avatar
Dave Griffiths committed
672
673
674
675
676
677
678
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

679
680
681
682
683
684
685
686
687
688
689
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (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
690
      (make-id "") 'horizontal (layout 'fill-parent 80 '1 'left 0) trans-col
691
692
693
      (list
       (vert
        (mtext "text" "Outcome")
694
695
696
        (spinner (make-id "gp-int-out") (list "Retreat" "Advance" "Fight & retreat" "Fight & win") fillwrap
                 (lambda (v)
                   (entity-add-value! "outcome" "varchar" v) '())))
697
698
       (vert
        (mtext "text" "Duration")
699
700
701
702
703
        (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
704
                  (list (replace-fragment (get-id "event-holder") "events"))))))))
705
706
707
708
709
710
711
712

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
      (populate-grid-selector
       "gp-int-pack" "single"
       (db-all db "sync" "pack")
713
714
       (lambda (pack)
         (entity-add-value! "id-other-pack" "varchar" (ktv-get pack "unique_id"))
715
716
717
718
719
720
         (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)
721
         (entity-add-value! "id-leader" "varchar" (ktv-get individual "unique_id"))
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
         (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
739
740
741
742
743
744
745
746
747
748
      (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
749
                (list (replace-fragment (get-id "event-holder") "events"))))))
750
751
752
753
754
755
756
757
758
759

   (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)
760
         (entity-add-value! "id-caller" "varchar" (ktv-get individual "unique_id"))
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
         (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
776
      (make-id "") 'horizontal (layout 'fill-parent 90 '1 'left 0) trans-col
777
      (list
778
779
780
781
782
783
       (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)) '()))))
784
     (linear-layout
785
      (make-id "") 'horizontal (layout 'fill-parent 90 '1 'left 0) trans-col
786
787
788
      (list
       (vert
        (mtext "" "Where to")
789
790
791
792
793
        (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
794
                  (list (replace-fragment (get-id "event-holder") "events"))))))))
795
796
797
798
799
800
801
802
803
804

   (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)
805
         (entity-add-value! "id-leader" "varchar" (ktv-get individual "unique_id"))
806
807
808
809
810
811
812
813
814
815
816
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))



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

817
818


819

Dave Griffiths's avatar
Dave Griffiths committed
820
  (fragment
821
   "gc-start"
822
   (linear-layout
823
    (make-id "") 'vertical fillwrap gc-col
824
825
826
827
828
    (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) '()))
829
     (build-grid-selector "gc-start-present" "toggle" "Who's present?")))
830
831
832
833
834
835

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
      (populate-grid-selector
836
       "gc-start-present" "toggle"
837
838
839
840
841
842
843
844
845
846
847
848
849
       (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
850
    (make-id "") 'vertical fillwrap gc-col
851
852
    (list
     (mtitle "title" "Weights")
853
     (build-grid-selector "gc-weigh-choose" "toggle" "Choose mongoose")
854
     (edit-text (make-id "gc-weigh-weight") "" 20 "numeric" fillwrap (lambda (v) '()))
855
     (mtoggle-button "gc-weigh-accurate" "Accurate?" (lambda (v) '()))))
856
857
858
859
860
861

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
      (populate-grid-selector
862
       "gc-weigh-choose" "toggle"
863
864
865
866
867
868
869
870
871
872
873
874
875
876
       (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
877
    (make-id "") 'vertical fillwrap gc-col
878
879
    (list
     (mtitle "title" "Pregnant females")
880
     (build-grid-selector "gc-preg-choose" "toggle" "Choose")))
881
882
883
884
885

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
886
887
      (populate-grid-selector
       "gc-preg-choose" "toggle"
888
889
890
891
892
893
894
895
896
897
898
       (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) '()))

899

900
901
902
  (fragment
   "gc-pup-assoc"
   (linear-layout
903
    (make-id "") 'vertical fillwrap gc-col
904
    (list
905
     (mtitle "title" "Pup Associations")
906
907
     (build-grid-selector "gc-pup-choose" "toggle" "Choose pup")
     (build-grid-selector "gc-pup-escort" "toggle" "Escort")))
908
909
910
911
912

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
913
914
      (populate-grid-selector
       "gc-pup-choose" "toggle"
915
916
917
918
919
       (db-all-where
        db "sync" "mongoose"
        (list "pack-id" (ktv-get (get-current 'pack '()) "unique_id")))
       (lambda (individual)
         (list)))
920
921
      (populate-grid-selector
       "gc-pup-escort" "toggle"
922
923
924
925
926
927
928
929
930
931
932
933
934
935
       (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
936
    (make-id "") 'vertical fillwrap gc-col
937
938
939
940
941
942
943
944
945
946
947
948
949
950
    (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
951
    (make-id "") 'vertical fillwrap gc-col
952
953
954
955
956
957
958
959
960
961
    (list
     (mtext "" "Babysittings...")))
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))
962

963
964
965
  (fragment
   "gc-end"
   (linear-layout
966
    (make-id "") 'vertical fillwrap gc-col
967
968
    (list
     (mtext "" "end!...")))
Dave Griffiths's avatar
Dave Griffiths committed
969
970
   (lambda (fragment arg)
     (activity-layout fragment))
971
972
   (lambda (fragment arg)
     (list))
Dave Griffiths's avatar
Dave Griffiths committed
973
974
975
976
977
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

978
979


Dave Griffiths's avatar
Dave Griffiths committed
980
981
  )

982
983
984
985
(msg "one")

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

987
(define-activity-list
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
;  (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) '()))
1006

Dave Griffiths's avatar
Dave Griffiths committed
1007

1008
1009
1010
  (activity
   "main"
   (vert
Dave Griffiths's avatar
Dave Griffiths committed
1011
1012
    (text-view (make-id "main-title") "Mongoose 2000" 40 fillwrap)
    (text-view (make-id "main-about") "Advanced mongoose technology" 20 fillwrap)
1013
    (spacer 10)
1014
1015
1016
1017
    (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 "")))))
1018
    (mtext "foo" "Your ID")
Dave Griffiths's avatar
Dave Griffiths committed
1019
    (edit-text (make-id "main-id-text") "" 30 "text" fillwrap
1020
1021
1022
1023
               (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
1024
1025
    (mtext "foo" "Database")
    (horiz
1026
1027
     (mbutton2 "main-send" "Email" (lambda () (list)))
     (mbutton2 "main-sync" "Sync" (lambda () (list (start-activity "sync" 0 ""))))))
Dave Griffiths's avatar
Dave Griffiths committed
1028
1029
   (lambda (activity arg)
     (activity-layout activity))
1030
1031
1032
1033
1034
   (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
1035
1036
1037
1038
1039
1040
1041
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity requestcode resultcode) '()))

  (activity
1042
   "observations"
Dave Griffiths's avatar
Dave Griffiths committed
1043
   (vert
1044
1045
1046
    (text-view (make-id "title") "Start Observation" 40 fillwrap)
    (vert
     (mtext "type" "Choose observation type")
1047
     (horiz
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
      (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"))))))))
1069
    (build-grid-selector "choose-obs-pack-selector" "single" "Choose pack")
1070
1071
1072
    (mbutton
     "choose-obs-start" "Start"
     (lambda ()
1073
1074
1075
1076
1077
1078
1079
       ;; 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)
1080
             (else '())))))
1081
1082

       ;; go to observation
1083
1084
       (if (and (current-exists? 'pack)
                (current-exists? 'observation))
1085
1086
           (cond
            ((eq? (get-current 'observation "none") obs-pf)
1087
             (list (start-activity "pup-focal-start" 2 "")))
1088
            ((eq? (get-current 'observation "none") obs-gp)
1089
             (list (start-activity "group-events" 2 "")))
1090
            (else
1091
             (list (start-activity "group-composition" 2 ""))))
1092
1093
1094
1095
1096
           (list
            (alert-dialog
             "choose-obs-finish"
             "Need to specify a pack and an observation"
             (lambda () '()))))))
Dave Griffiths's avatar
Dave Griffiths committed
1097
1098
1099
    )
   (lambda (activity arg)
     (activity-layout activity))
1100
1101
   (lambda (activity arg)
     (list
1102
1103
1104
      (populate-grid-selector
       "choose-obs-pack-selector" "single"
       (db-all db "sync" "pack")
1105
       (lambda (pack)
1106
1107
1108
         (msg "in selector" pack)
         (set-current! 'pack pack)
         '()))))
Dave Griffiths's avatar
Dave Griffiths committed
1109
1110
1111
1112
1113
1114
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity requestcode resultcode) '()))

1115

Dave Griffiths's avatar
Dave Griffiths committed
1116
  (activity
1117
   "group-composition"
Dave Griffiths's avatar
Dave Griffiths committed
1118
1119
1120
1121
1122
1123
1124
1125
1126
    (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
1127
1128
   (lambda (activity arg)
     (activity-layout activity))
1129
   (lambda (activity arg)
1130
     (msg (get-current 'observation-fragments '()))
1131
     (list
1132
1133
1134
1135
1136
1137
1138
      (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)
1139
                          (msg "button-bar" frag)
1140
1141
1142
1143
1144
1145
1146
                          (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
1147
                                 (replace-fragment (get-id "gc-top") (cadr frag))))))))
1148
                        (get-current 'observation-fragments '()))))
1149
1150
1151
1152
      (update-widget 'text-view (get-id "obs-title") 'text
                     (string-append
                      (get-current 'observation "No observation")
                      " with " (ktv-get (get-current 'pack '()) "name")))
1153
      ))
Dave Griffiths's avatar
Dave Griffiths committed
1154
1155
1156
1157
1158
1159
1160
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity requestcode resultcode) '()))

  (activity
1161
   "pup-focal-start"
1162
   (linear-layout
1163
    0 'vertical fillwrap pf-bgcol
1164
1165
1166
1167
1168
1169
    (list
     (vert
      (mtitle "" "Pup focal setup")
      (mtext "pf1-pack" "Pack")
      (build-grid-selector "pf1-grid" "single" "Select pup")
      (horiz
1170
1171
1172
1173
1174
1175
       (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) '()))
1176
1177
      (mbutton "pf1-done" "Done"
               (lambda ()
1178
                 (set-current! 'pup-focal-id (entity-record-values db "stream" "pup-focal"))
1179
1180
                 (list
                  (start-activity "pup-focal" 2 ""))))
1181
      )))
Dave Griffiths's avatar
Dave Griffiths committed
1182
1183
   (lambda (activity arg)
     (activity-layout activity))
1184
1185
   (lambda (activity arg)
     (list
1186
1187
1188
1189
      (populate-grid-selector
       "pf1-grid" "single"
       (db-all-where db "sync" "mongoose" (list "pack-id" (ktv-get (get-current 'pack '()) "unique_id")))
       (lambda (individual)
1190
         (set-current! 'individual individual)
1191
         (entity-add-value! "id-focal-subject" "varchar" (ktv-get individual "unique_id"))
1192
         '()))))
Dave Griffiths's avatar
Dave Griffiths committed
1193
1194
1195
1196
1197
1198
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity requestcode resultcode) '()))

1199

Dave Griffiths's avatar
Dave Griffiths committed
1200
  (activity
1201
   "pup-focal"
1202
    (linear-layout
1203
     0 'vertical fillwrap pf-bgcol
1204
     (list
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
      (horiz
       (mtitle "title" "Pup Focal")
       (vert
        (mtext "title" "Time left:")
        (mtitle "pf-timer-time-minutes" "20"))
       (vert
        (mtext "title" "Next scan:")
        (mtitle "pf-timer-time" "60"))
       (mtoggle-button "pf-pause" "Pause"
                       (lambda (v)
                         (msg "pausing")
                         (if v
                             (list (delayed "timer" 1000 (lambda () '())))
                             (list (delayed "timer" 1000 timer-cb))))))
      (build-fragment "pf-timer" (make-id "pf-top") (layout 595 400 1 'left 0))
Dave Griffiths's avatar
Dave Griffiths committed
1220
      (build-fragment "events" (make-id "event-holder") (layout 595 450 1 'left 0))
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
      (mbutton "pf-done" "Done" (lambda () (list (finish-activity 0))))))

    (lambda (activity arg)
      (activity-layout activity))
    (lambda (activity arg)
      (set-current! 'timer-minutes 20)
      (set-current! 'timer-seconds 59)
      (list
       (delayed "timer" 1000 timer-cb)))
    (lambda (activity) '())
    (lambda (activity) (list (delayed "timer" 1000 (lambda () '()))))
    (lambda (activity) (list (delayed "timer" 1000 (lambda () '()))))
    (lambda (activity) '())
    (lambda (activity requestcode resultcode) '()))
Dave Griffiths's avatar
Dave Griffiths committed
1235

1236

Dave Griffiths's avatar
Dave Griffiths committed
1237
  (activity
1238
   "group-events"
1239
1240
1241
   (linear-layout
    0 'vertical wrap gp-col
    (list
Dave Griffiths's avatar
Dave Griffiths committed
1242
     (build-fragment "events" (make-id "event-holder") (layout 580 450 1 'left 0))
1243
1244
1245
     (horiz
      (mbutton "gpe-save" "Save" (lambda () (list)))
      (mbutton "gpe-done" "Done" (lambda () (list (finish-activity 0)))))))