starwisp.scm 50.8 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

136
137
138
139
140
141
142
(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)) ":"
143
   (substring (number->string (+ 100 (list-ref dt 5))) 1 2)))
144

145
146
;; build entity from all ktvs, insert to db, return unique_id
(define (entity-record-values db table type)
147
148
149
150
151
  ;; 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)
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
  (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))))

(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))
174

Dave Griffiths's avatar
Dave Griffiths committed
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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
196
197
   "&dirty=" (number->string (list-ref (car e) 2))
   "&version=" (number->string (list-ref (car e) 3))
Dave Griffiths's avatar
Dave Griffiths committed
198
199
200
201
202
203
204
205
206
207
208
209
   (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
210
211
212
213
            (begin
              (update-entity-clean db table (cadr v))
              (toast "Uploaded " (ktv-get (cadr e) "name")))
            (toast "Problem uploading " (ktv-get (cadr e) "name"))))))
214
   (dirty-entities db table)))
Dave Griffiths's avatar
Dave Griffiths committed
215

216
(define (suck-entity-from-server db table unique-id exists)
Dave Griffiths's avatar
Dave Griffiths committed
217
218
219
220
221
222
223
  ;; 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'
224
225
     (let ((entity (list-ref data 0))
           (ktvlist (list-ref data 1)))
Dave Griffiths's avatar
Dave Griffiths committed
226
       (if (not exists)
227
228
229
230
231
232
233
234
           (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
235
236
           (update-to-version
            db table (get-entity-id db table unique-id)
Dave Griffiths's avatar
Dave Griffiths committed
237
238
239
240
            (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
241

Dave Griffiths's avatar
Dave Griffiths committed
242
;; repeatedly read version and request updates
Dave Griffiths's avatar
Dave Griffiths committed
243
(define (suck-new db table)
Dave Griffiths's avatar
Dave Griffiths committed
244
245
246
  (list
   (http-request
    "new-entities-req"
247
    (string-append url "fn=entity-versions&table=" table)
Dave Griffiths's avatar
Dave Griffiths committed
248
    (lambda (data)
Dave Griffiths's avatar
Dave Griffiths committed
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
      (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
269

270
271
272
273
274
275
276
277
278
(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
279
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
280
;; user interface abstraction
Dave Griffiths's avatar
Dave Griffiths committed
281

Dave Griffiths's avatar
Dave Griffiths committed
282
283
284
(define (mbutton id title fn)
  (button (make-id id) title 20 fillwrap fn))

285
(define (mbutton2 id title fn)
286
  (button (make-id id) title 20 (layout 150 100 1 'centre 0) fn))
287

288
289
290
(define (mtoggle-button id title fn)
  (toggle-button (make-id id) title 20 fillwrap fn))

291
(define (mtoggle-button2 id title fn)
292
  (toggle-button (make-id id) title 20 (layout 150 100 1 'centre 0) fn))
293

Dave Griffiths's avatar
Dave Griffiths committed
294
295
(define (mtext id text)
  (text-view (make-id id) text 20 fillwrap))
296

297
298
299
(define (mtitle id text)
  (text-view (make-id id) text 40 fillwrap))

300
301
(define (medit-text id text type fn)
  (vert
302
303
   (mtext (string-append id "-title") text)
   (edit-text (make-id id) "" 20 type fillwrap fn)))
304
305
306
307
308
309
310

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

311
312
313
314
315
316
317
(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))

318
319
320
321
322
323
324
325
326
327
(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))

328
329
;;;;

330
(define (build-grid-selector name type title)
331
  (vert
332
   (mtext "title" title)
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
   (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))))))
349

350
;; assumes grid selectors on mongeese only
351
352
353
(define (fast-get-name item)
  (list-ref (list-ref item 1) 2))

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

363
364
365
(define (populate-grid-selector name type items fn)
  (let ((id->items (build-button-items name items))
        (selected-set '()))
366
367
368
    (update-widget
     'button-grid (get-id name) 'grid-buttons
     (list
369
      type 3 20 (layout 100 40 1 'left 0)
370
371
372
373
      (map
       (lambda (ii)
         (list (car ii) (caddr ii)))
       id->items)
374
375
      (lambda (v state)
        (cond
376
377
         ((equal? type "toggle")
          ;; update list of selected items
378
379
380
381
382
383
384
385
386
387
          (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))
388
389
          (fn (cadr (findv v id->items))))))))))

390
391
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
Dave Griffiths's avatar
Dave Griffiths committed
392

393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
(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))))
    )))

415
416
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; fragments
Dave Griffiths's avatar
Dave Griffiths committed
417
418
419

(define-fragment-list

420
421
422
  (fragment
   "pf-timer"
   (linear-layout
423
    (make-id "") 'vertical fillwrap trans-col
424
    (list
425
     (mtitle "pf-details" "Pack: xxx Pup: xxx")))
426
427
428
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
429
430
431
432
433
434
     (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"))
                     )))
435
436
437
438
439
440
441
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


  (fragment
442
   "events"
443
   (linear-layout
444
    0 'vertical fillwrap trans-col
445
    (list
446
     (linear-layout
447
      (make-id "ev-pf") 'vertical wrapfill pf-col
448
      (list
449
450
       (mtitle "ev-pf-text" "Pup Focal Events")
       (horiz
Dave Griffiths's avatar
Dave Griffiths committed
451
452
453
454
        (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")))))))
455
     (linear-layout
456
      (make-id "ev-pf") 'vertical fill gp-col
457
      (list
458
459
       (mtitle "text" "Group Events")
       (horiz
Dave Griffiths's avatar
Dave Griffiths committed
460
461
462
        (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")))))))))
463
464
465
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
466
     (if (equal? (get-current 'observation "none") obs-pf)
467
468
         (list
          (update-widget 'text-view (get-id "ev-pf-text") 'show 0)
Dave Griffiths's avatar
Dave Griffiths committed
469
470
471
472
          (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))))
473
474
475
476
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))
477

478
479
480
  (fragment
   "pf-scan1"
   (linear-layout
481
    (make-id "") 'vertical fillwrap pf-col
482
    (list
483
484
485
     (mtext "title" "Nearest Neighbour Scan")
     (build-grid-selector "pf-scan-nearest" "single" "Closest Mongoose")
     (build-grid-selector "pf-scan-close" "toggle" "Mongooses within 2m")
486
487
488
489
     (mbutton "pf-scan-done" "Done"
              (lambda ()
                (entity-add-value! "parent" "varchar" (get-current 'pup-focal-id ""))
                (entity-record-values db "stream" "pup-focal-nearest")
490
                (list (replace-fragment (get-id "pf-top") "pf-timer"))))))
491
492
493
494

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
495
496
     (list
      (populate-grid-selector
497
       "pf-scan-nearest" "single"
498
499
       (db-all-where db "sync" "mongoose"
                     (list "pack-id" (ktv-get (get-current 'pack '()) "unique_id")))
500
501
       (lambda (individual)
         (entity-add-value! "id-nearest" "varchar" (ktv-get individual "unique_id"))
502
503
         (list)))
      (populate-grid-selector
504
       "pf-scan-close" "toggle"
505
506
       (db-all-where db "sync" "mongoose"
                     (list "pack-id" (ktv-get (get-current 'pack '()) "unique_id")))
507
508
       (lambda (individuals)
         (entity-add-value! "id-list-close" "varchar" (assemble-array individuals))
509
510
         (list)))
      ))
511
512
513
514
515
516
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


517
518
519
  (fragment
   "ev-pupfeed"
   (linear-layout
520
    (make-id "") 'vertical fillwrap pf-col
521
    (list
522
     (mtitle "title" "Event: Pup is fed")
523
524
525
     (build-grid-selector "pf-pupfeed-who" "single" "Who fed the pup?")
     (mtext "text" "Food size")
     (horiz
526
527
528
529
530
531
532
      (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
533
                 (list (replace-fragment (get-id "event-holder") "events")))))))
534
535
536
537
538
539
540
541
542
543

   (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)
544
         (entity-add-value! "id-who" "varchar" (ktv-get individual "unique_id"))
545
546
547
548
549
550
551
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

Dave Griffiths's avatar
Dave Griffiths committed
552
553
554
  (fragment
   "ev-pupfind"
   (linear-layout
555
    (make-id "") 'vertical fillwrap pf-col
Dave Griffiths's avatar
Dave Griffiths committed
556
    (list
557
     (mtitle "title" "Event: Pup found food")
Dave Griffiths's avatar
Dave Griffiths committed
558
559
     (mtext "text" "Food size")
     (horiz
560
561
562
563
564
565
      (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
566
                 (list (replace-fragment (get-id "event-holder") "events")))))))
Dave Griffiths's avatar
Dave Griffiths committed
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581

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


  (fragment
   "ev-pupcare"
   (linear-layout
582
    (make-id "") 'vertical fillwrap pf-col
Dave Griffiths's avatar
Dave Griffiths committed
583
    (list
584
     (mtitle "title" "Event: Pup is cared for")
Dave Griffiths's avatar
Dave Griffiths committed
585
586
587
     (build-grid-selector "pf-pupcare-who" "single" "Who cared for the pup?")
     (mtext "text" "Type of care")
     (horiz
588
589
590
591
592
593
594
      (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
595
                 (list (replace-fragment (get-id "event-holder") "events")))))))
Dave Griffiths's avatar
Dave Griffiths committed
596
597
598
599
600
601
602
603
604
605

   (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)
606
         (entity-add-value! "id-who" "varchar" (ktv-get individual "unique_id"))
Dave Griffiths's avatar
Dave Griffiths committed
607
608
609
610
611
612
613
614
615
616
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "ev-pupaggr"
   (linear-layout
617
    (make-id "") 'vertical fillwrap pf-col
Dave Griffiths's avatar
Dave Griffiths committed
618
    (list
619
     (mtitle "title" "Event: Pup aggression")
Dave Griffiths's avatar
Dave Griffiths committed
620
621
622
     (build-grid-selector "pf-pupaggr-partner" "single" "Aggressive mongoose")

     (linear-layout
623
      (make-id "") 'horizontal (layout 'fill-parent 100 '1 'left 0) trans-col
Dave Griffiths's avatar
Dave Griffiths committed
624
625
626
      (list
       (vert
        (mtext "" "Fighting over")
627
628
629
        (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
630
631
       (vert
        (mtext "" "Level")
632
633
634
635
636
        (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)
637
                         (entity-add-value! "initiate" "varchar" (if v "yes" "no")) '()))
638
639
       (mtoggle-button "pf-pupaggr-win" "Win?"
                       (lambda (v)
640
                         (entity-add-value! "win" "varchar" (if v "yes" "no")) '()))))
641
642
643
644
     (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
645
                (list (replace-fragment (get-id "event-holder") "events"))))))
Dave Griffiths's avatar
Dave Griffiths committed
646
647
648
649
650
651
652
653
654
655

   (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)
656
         (entity-add-value! "id-with" "varchar" (ktv-get individual "unique_id"))
Dave Griffiths's avatar
Dave Griffiths committed
657
658
659
660
661
662
663
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

664
665
666
667
668
669
670
671
672
673
674
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (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
675
      (make-id "") 'horizontal (layout 'fill-parent 80 '1 'left 0) trans-col
676
677
678
      (list
       (vert
        (mtext "text" "Outcome")
679
680
681
        (spinner (make-id "gp-int-out") (list "Retreat" "Advance" "Fight & retreat" "Fight & win") fillwrap
                 (lambda (v)
                   (entity-add-value! "outcome" "varchar" v) '())))
682
683
       (vert
        (mtext "text" "Duration")
684
685
686
687
688
        (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
689
                  (list (replace-fragment (get-id "event-holder") "events"))))))))
690
691
692
693
694
695
696
697

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
      (populate-grid-selector
       "gp-int-pack" "single"
       (db-all db "sync" "pack")
698
699
       (lambda (pack)
         (entity-add-value! "id-other-pack" "varchar" (ktv-get pack "unique_id"))
700
701
702
703
704
705
         (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)
706
         (entity-add-value! "id-leader" "varchar" (ktv-get individual "unique_id"))
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
         (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
724
725
726
727
728
729
730
731
732
733
      (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
734
                (list (replace-fragment (get-id "event-holder") "events"))))))
735
736
737
738
739
740
741
742
743
744

   (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)
745
         (entity-add-value! "id-caller" "varchar" (ktv-get individual "unique_id"))
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
         (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
761
      (make-id "") 'horizontal (layout 'fill-parent 90 '1 'left 0) trans-col
762
      (list
763
764
765
766
767
768
       (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)) '()))))
769
     (linear-layout
770
      (make-id "") 'horizontal (layout 'fill-parent 90 '1 'left 0) trans-col
771
772
773
      (list
       (vert
        (mtext "" "Where to")
774
775
776
777
778
        (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
779
                  (list (replace-fragment (get-id "event-holder") "events"))))))))
780
781
782
783
784
785
786
787
788
789

   (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)
790
         (entity-add-value! "id-leader" "varchar" (ktv-get individual "unique_id"))
791
792
793
794
795
796
797
798
799
800
801
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))



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

802
803


804

Dave Griffiths's avatar
Dave Griffiths committed
805
  (fragment
806
   "gc-start"
807
   (linear-layout
808
    (make-id "") 'vertical fillwrap gc-col
809
810
811
812
813
    (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) '()))
814
     (build-grid-selector "gc-start-present" "toggle" "Who's present?")))
815
816
817
818
819
820

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
      (populate-grid-selector
821
       "gc-start-present" "toggle"
822
823
824
825
826
827
828
829
830
831
832
833
834
       (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
835
    (make-id "") 'vertical fillwrap gc-col
836
837
    (list
     (mtitle "title" "Weights")
838
     (build-grid-selector "gc-weigh-choose" "toggle" "Choose mongoose")
839
     (edit-text (make-id "gc-weigh-weight") "" 20 "numeric" fillwrap (lambda (v) '()))
840
     (mtoggle-button "gc-weigh-accurate" "Accurate?" (lambda (v) '()))))
841
842
843
844
845
846

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
      (populate-grid-selector
847
       "gc-weigh-choose" "toggle"
848
849
850
851
852
853
854
855
856
857
858
859
860
861
       (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
862
    (make-id "") 'vertical fillwrap gc-col
863
864
    (list
     (mtitle "title" "Pregnant females")
865
     (build-grid-selector "gc-preg-choose" "toggle" "Choose")))
866
867
868
869
870

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
871
872
      (populate-grid-selector
       "gc-preg-choose" "toggle"
873
874
875
876
877
878
879
880
881
882
883
       (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) '()))

884

885
886
887
  (fragment
   "gc-pup-assoc"
   (linear-layout
888
    (make-id "") 'vertical fillwrap gc-col
889
    (list
890
     (mtitle "title" "Pup Associations")
891
892
     (build-grid-selector "gc-pup-choose" "toggle" "Choose pup")
     (build-grid-selector "gc-pup-escort" "toggle" "Escort")))
893
894
895
896
897

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
898
899
      (populate-grid-selector
       "gc-pup-choose" "toggle"
900
901
902
903
904
       (db-all-where
        db "sync" "mongoose"
        (list "pack-id" (ktv-get (get-current 'pack '()) "unique_id")))
       (lambda (individual)
         (list)))
905
906
      (populate-grid-selector
       "gc-pup-escort" "toggle"
907
908
909
910
911
912
913
914
915
916
917
918
919
920
       (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
921
    (make-id "") 'vertical fillwrap gc-col
922
923
924
925
926
927
928
929
930
931
932
933
934
935
    (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
936
    (make-id "") 'vertical fillwrap gc-col
937
938
939
940
941
942
943
944
945
946
    (list
     (mtext "" "Babysittings...")))
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))
947

948
949
950
  (fragment
   "gc-end"
   (linear-layout
951
    (make-id "") 'vertical fillwrap gc-col
952
953
    (list
     (mtext "" "end!...")))
Dave Griffiths's avatar
Dave Griffiths committed
954
955
   (lambda (fragment arg)
     (activity-layout fragment))
956
957
   (lambda (fragment arg)
     (list))
Dave Griffiths's avatar
Dave Griffiths committed
958
959
960
961
962
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

963
964


Dave Griffiths's avatar
Dave Griffiths committed
965
966
  )

967
968
969
970
(msg "one")

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

972
(define-activity-list
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
;  (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) '()))
991

Dave Griffiths's avatar
Dave Griffiths committed
992

993
994
995
  (activity
   "main"
   (vert
Dave Griffiths's avatar
Dave Griffiths committed
996
997
    (text-view (make-id "main-title") "Mongoose 2000" 40 fillwrap)
    (text-view (make-id "main-about") "Advanced mongoose technology" 20 fillwrap)
998
    (spacer 10)
999
1000
1001
1002
    (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 "")))))
1003
    (mtext "foo" "Your ID")
Dave Griffiths's avatar
Dave Griffiths committed
1004
    (edit-text (make-id "main-id-text") "" 30 "text" fillwrap
1005
1006
1007
1008
               (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
1009
1010
    (mtext "foo" "Database")
    (horiz
1011
1012
     (mbutton2 "main-send" "Email" (lambda () (list)))
     (mbutton2 "main-sync" "Sync" (lambda () (list (start-activity "sync" 0 ""))))))
Dave Griffiths's avatar
Dave Griffiths committed
1013
1014
   (lambda (activity arg)
     (activity-layout activity))
1015
1016
1017
1018
1019
   (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
1020
1021
1022
1023
1024
1025
1026
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity requestcode resultcode) '()))

  (activity
1027
   "observations"
Dave Griffiths's avatar
Dave Griffiths committed
1028
   (vert
1029
1030
1031
    (text-view (make-id "title") "Start Observation" 40 fillwrap)
    (vert
     (mtext "type" "Choose observation type")
1032
     (horiz
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
      (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"))))))))
1054
    (build-grid-selector "choose-obs-pack-selector" "single" "Choose pack")
1055
1056
1057
    (mbutton
     "choose-obs-start" "Start"
     (lambda ()
1058
1059
1060
1061
1062
1063
1064
       ;; 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)
1065
             (else '())))))
1066
1067

       ;; go to observation
1068
1069
       (if (and (current-exists? 'pack)
                (current-exists? 'observation))
1070
1071
           (cond
            ((eq? (get-current 'observation "none") obs-pf)
1072
             (list (start-activity "pup-focal-start" 2 "")))
1073
            ((eq? (get-current 'observation "none") obs-gp)
1074
             (list (start-activity "group-events" 2 "")))
1075
            (else
1076
             (list (start-activity "group-composition" 2 ""))))
1077
1078
1079
1080
1081
           (list
            (alert-dialog
             "choose-obs-finish"
             "Need to specify a pack and an observation"
             (lambda () '()))))))
Dave Griffiths's avatar
Dave Griffiths committed
1082
1083
1084
    )
   (lambda (activity arg)
     (activity-layout activity))
1085
1086
   (lambda (activity arg)
     (list
1087
1088
1089
      (populate-grid-selector
       "choose-obs-pack-selector" "single"
       (db-all db "sync" "pack")
1090
       (lambda (pack)
1091
1092
1093
         (msg "in selector" pack)
         (set-current! 'pack pack)
         '()))))
Dave Griffiths's avatar
Dave Griffiths committed
1094
1095
1096
1097
1098
1099
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity requestcode resultcode) '()))

1100

Dave Griffiths's avatar
Dave Griffiths committed
1101
  (activity
1102
   "group-composition"
Dave Griffiths's avatar
Dave Griffiths committed
1103
1104
1105
1106
1107
1108
1109
1110
1111
    (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
1112
1113
   (lambda (activity arg)
     (activity-layout activity))
1114
   (lambda (activity arg)
1115
     (msg (get-current 'observation-fragments '()))
1116
     (list
1117
1118
1119
1120
1121
1122
1123
      (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)
1124
                          (msg "button-bar" frag)
1125
1126
1127
1128
1129
1130
1131
                          (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
1132
                                 (replace-fragment (get-id "gc-top") (cadr frag))))))))
1133
                        (get-current 'observation-fragments '()))))
1134
1135
1136
1137
      (update-widget 'text-view (get-id "obs-title") 'text
                     (string-append
                      (get-current 'observation "No observation")
                      " with " (ktv-get (get-current 'pack '()) "name")))
1138
      ))
Dave Griffiths's avatar
Dave Griffiths committed
1139
1140
1141
1142
1143
1144
1145
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity requestcode resultcode) '()))

  (activity
1146
   "pup-focal-start"
1147
   (linear-layout
1148
    0 'vertical fillwrap pf-bgcol
1149
1150
1151
1152
1153
1154
    (list
     (vert
      (mtitle "" "Pup focal setup")
      (mtext "pf1-pack" "Pack")
      (build-grid-selector "pf1-grid" "single" "Select pup")
      (horiz
1155
1156
1157
1158
1159
1160
       (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) '()))
1161
1162
      (mbutton "pf1-done" "Done"
               (lambda ()
1163
                 (set-current! 'pup-focal-id (entity-record-values db "stream" "pup-focal"))
1164
1165
                 (list
                  (start-activity "pup-focal" 2 ""))))
1166
      )))
Dave Griffiths's avatar
Dave Griffiths committed
1167
1168
   (lambda (activity arg)
     (activity-layout activity))
1169
1170
   (lambda (activity arg)
     (list
1171
1172
1173
1174
      (populate-grid-selector
       "pf1-grid" "single"
       (db-all-where db "sync" "mongoose" (list "pack-id" (ktv-get (get-current 'pack '()) "unique_id")))
       (lambda (individual)
1175
         (set-current! 'individual individual)
1176
         (entity-add-value! "id-focal-subject" "varchar" (ktv-get individual "unique_id"))
1177
         '()))))
Dave Griffiths's avatar
Dave Griffiths committed
1178
1179
1180
1181
1182
1183
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity requestcode resultcode) '()))

1184

Dave Griffiths's avatar
Dave Griffiths committed
1185
  (activity
1186
   "pup-focal"
1187
    (linear-layout
1188
     0 'vertical fillwrap pf-bgcol
1189
     (list
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
      (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
1205
      (build-fragment "events" (make-id "event-holder") (layout 595 450 1 'left 0))
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
      (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
1220

1221

Dave Griffiths's avatar
Dave Griffiths committed
1222
  (activity
1223
   "group-events"
1224
1225
1226
   (linear-layout
    0 'vertical wrap gp-col
    (list
Dave Griffiths's avatar
Dave Griffiths committed
1227
     (build-fragment "events" (make-id "event-holder") (layout 580 450 1 'left 0))
1228
1229
1230
     (horiz
      (mbutton "gpe-save" "Save" (lambda () (list)))
      (mbutton "gpe-done" "Done" (lambda () (list (finish-activity 0)))))))
Dave Griffiths's avatar
Dave Griffiths committed
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
   (lambda (activity arg)
     (activity-layout activity))
   (lambda (activity arg) (list))
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity requestcode resultcode) '()))


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

  (activity
   "manage-packs"
   (vert
    (text-view (make-id "title") "Manage packs" 40 fillwrap)
1247
    (build-grid-selector "manage-packs-list" "button" "Choose pack")