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

16
17
18
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
   (build-url-from-ktvlist (cadr e))))

;; spit all dirty entities to server
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
(define (spit db table entities)
  (foldl
   (lambda (e r)
     (append
      (list
       (debug (string-append "Sending a " (car (car e)) " to Raspberry Pi"))
       (http-request
        (string-append "req-" (list-ref (car e) 1))
        (build-url-from-entity table e)
        (lambda (v)
          (msg "spat" e v)
          (cond
           ((or (equal? (car v) "inserted") (equal? (car v) "match"))
            (update-entity-clean db table (cadr v))
            (list
             (debug (string-append "Uploaded " (car (car e))))))
           ((equal? (car v) "no change")
            (list (debug (string-append "No change for " (car (car e))))))
           ((equal? (car v) "updated")
            (update-entity-clean db table (cadr v))
            (list (debug (string-append "Updated changed " (car (car e))))))
           (else
            (list (toast (string-append
                          "Problem uploading "
                          (car (car e)) " : " (car v)))
                  (debug (string-append
                          "Problem uploading "
                          (car (car e)) " : " (car v)))))))))
      r))
   '()
   entities))
247

248
(define (suck-entity-from-server db table unique-id exists)
Dave Griffiths's avatar
Dave Griffiths committed
249
250
251
252
253
254
255
  ;; 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'
256
257
     (let ((entity (list-ref data 0))
           (ktvlist (list-ref data 1)))
Dave Griffiths's avatar
Dave Griffiths committed
258
       (if (not exists)
259
260
261
262
263
264
265
           (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
266
267
           (update-to-version
            db table (get-entity-id db table unique-id)
268
            (list-ref entity 2) ktvlist))
Dave Griffiths's avatar
Dave Griffiths committed
269
270
       (list
        (update-widget 'text-view (get-id "sync-dirty") 'text (build-dirty))
271
        (debug (string-append (if exists "Got new: " "Updated: ") (ktv-get ktvlist "name")))
Dave Griffiths's avatar
Dave Griffiths committed
272
        (toast (string-append "Downloaded " (ktv-get ktvlist "name"))))))))
Dave Griffiths's avatar
Dave Griffiths committed
273

Dave Griffiths's avatar
Dave Griffiths committed
274
;; repeatedly read version and request updates
Dave Griffiths's avatar
Dave Griffiths committed
275
(define (suck-new db table)
Dave Griffiths's avatar
Dave Griffiths committed
276
  (list
277
   (debug "Requesting new entities")
Dave Griffiths's avatar
Dave Griffiths committed
278
279
   (http-request
    "new-entities-req"
280
    (string-append url "fn=entity-versions&table=" table)
Dave Griffiths's avatar
Dave Griffiths committed
281
    (lambda (data)
Dave Griffiths's avatar
Dave Griffiths committed
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
      (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)
300
301
302
303
304
305
306
307
            (append
             (list
              (debug "All files up to date")
              (toast "All files up to date")) r)
            (append
             (list
              (debug (string-append "Requesting " (number->string (length r)) " entities"))
              (toast (string-append "Requesting " (number->string (length r)) " entities"))) r)))))))
Dave Griffiths's avatar
Dave Griffiths committed
308

309
310
311
312
313
314
315
316
317
(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
318
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
319
;; user interface abstraction
Dave Griffiths's avatar
Dave Griffiths committed
320

Dave Griffiths's avatar
Dave Griffiths committed
321
322
323
(define (mbutton id title fn)
  (button (make-id id) title 20 fillwrap fn))

324
(define (mbutton2 id title fn)
325
  (button (make-id id) title 20 (layout 150 100 1 'centre 0) fn))
326

327
328
329
(define (mtoggle-button id title fn)
  (toggle-button (make-id id) title 20 fillwrap fn))

330
(define (mtoggle-button2 id title fn)
331
  (toggle-button (make-id id) title 20 (layout 150 100 1 'centre 0) fn))
332

Dave Griffiths's avatar
Dave Griffiths committed
333
334
(define (mtext id text)
  (text-view (make-id id) text 20 fillwrap))
335

336
337
338
(define (mtitle id text)
  (text-view (make-id id) text 40 fillwrap))

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

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

350
351
352
353
354
355
356
(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))

357
358
359
360
361
362
363
364
365
366
(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))

367
368
;;;;

369
(define (build-grid-selector name type title)
370
  (vert
371
   (mtext "title" title)
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
   (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))))))
388

389
;; assumes grid selectors on mongeese only
390
391
392
(define (fast-get-name item)
  (list-ref (list-ref item 1) 2))

393
394
395
396
397
398
399
400
401
(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))

402
(define (populate-grid-selector name type items fn)
403
404
  (prof-start "popgrid")
  (prof-start "popgrid setup")
405
406
  (let ((id->items (build-button-items name items))
        (selected-set '()))
407
408
    (prof-end "popgrid setup")
    (let ((r (update-widget
409
410
     'button-grid (get-id name) 'grid-buttons
     (list
411
      type 3 20 (layout 100 40 1 'left 0)
412
413
414
415
      (map
       (lambda (ii)
         (list (car ii) (caddr ii)))
       id->items)
416
417
      (lambda (v state)
        (cond
418
419
         ((equal? type "toggle")
          ;; update list of selected items
420
421
422
423
424
425
426
427
428
429
          (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))
430
          (fn (cadr (findv v id->items))))))))))
431
432
433
434
435
436
437
      (prof-end "popgrid")
      r)))

(define (db-mongooses-by-pack)
  (db-all-where2
   db "sync" "mongoose"
   (ktv "pack-id" "varchar" (ktv-get (get-current 'pack '()) "unique_id"))))
438

439
440
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
Dave Griffiths's avatar
Dave Griffiths committed
441

442
443
444
445
446
447
(define (debug txt)
  (set-current! 'debug-text (string-append txt "\n" (get-current 'debug-text "")))
  (update-widget 'debug-text-view (get-id "sync-debug") 'text
                 (get-current 'debug-text "")))


448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
(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))))
    )))

470
471
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; fragments
Dave Griffiths's avatar
Dave Griffiths committed
472
473
474

(define-fragment-list

475
476
477
  (fragment
   "pf-timer"
   (linear-layout
478
    (make-id "") 'vertical fillwrap trans-col
479
    (list
480
     (mtitle "pf-details" "Pack: xxx Pup: xxx")))
481
482
483
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
484
485
486
487
488
489
     (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"))
                     )))
490
491
492
493
494
495
496
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


  (fragment
497
   "events"
498
   (linear-layout
499
    0 'vertical fillwrap trans-col
500
    (list
501
     (linear-layout
Dave Griffiths's avatar
Dave Griffiths committed
502
      (make-id "ev-pf") 'vertical fill pf-col
503
      (list
504
505
       (mtitle "ev-pf-text" "Pup Focal Events")
       (horiz
Dave Griffiths's avatar
Dave Griffiths committed
506
507
508
509
        (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")))))))
510
     (linear-layout
511
      (make-id "ev-pf") 'vertical fill gp-col
512
      (list
513
514
       (mtitle "text" "Group Events")
       (horiz
Dave Griffiths's avatar
Dave Griffiths committed
515
516
517
        (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")))))))))
518
519
520
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
521
     (if (equal? (get-current 'observation "none") obs-pf)
522
523
         (list
          (update-widget 'text-view (get-id "ev-pf-text") 'show 0)
Dave Griffiths's avatar
Dave Griffiths committed
524
525
526
527
          (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))))
528
529
530
531
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))
532

533
534
535
  (fragment
   "pf-scan1"
   (linear-layout
536
    (make-id "") 'vertical fillwrap pf-col
537
    (list
538
539
540
     (mtext "title" "Nearest Neighbour Scan")
     (build-grid-selector "pf-scan-nearest" "single" "Closest Mongoose")
     (build-grid-selector "pf-scan-close" "toggle" "Mongooses within 2m")
541
542
543
544
     (mbutton "pf-scan-done" "Done"
              (lambda ()
                (entity-add-value! "parent" "varchar" (get-current 'pup-focal-id ""))
                (entity-record-values db "stream" "pup-focal-nearest")
545
                (list (replace-fragment (get-id "pf-top") "pf-timer"))))))
546
547
548
549

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
550
551
     (list
      (populate-grid-selector
552
       "pf-scan-nearest" "single"
553
       (db-mongooses-by-pack)
554
555
       (lambda (individual)
         (entity-add-value! "id-nearest" "varchar" (ktv-get individual "unique_id"))
556
557
         (list)))
      (populate-grid-selector
558
       "pf-scan-close" "toggle"
559
       (db-mongooses-by-pack)
560
561
       (lambda (individuals)
         (entity-add-value! "id-list-close" "varchar" (assemble-array individuals))
562
563
         (list)))
      ))
564
565
566
567
568
569
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


570
571
572
  (fragment
   "ev-pupfeed"
   (linear-layout
573
    (make-id "") 'vertical fillwrap pf-col
574
    (list
575
     (mtitle "title" "Event: Pup is fed")
576
577
578
     (build-grid-selector "pf-pupfeed-who" "single" "Who fed the pup?")
     (mtext "text" "Food size")
     (horiz
579
580
581
582
583
584
585
      (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
586
                 (list (replace-fragment (get-id "event-holder") "events")))))))
587
588
589
590
591
592
593

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
      (populate-grid-selector
       "pf-pupfeed-who" "single"
594
       (db-mongooses-by-pack)
595
       (lambda (individual)
596
         (entity-add-value! "id-who" "varchar" (ktv-get individual "unique_id"))
597
598
599
600
601
602
603
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

Dave Griffiths's avatar
Dave Griffiths committed
604
605
606
  (fragment
   "ev-pupfind"
   (linear-layout
607
    (make-id "") 'vertical fillwrap pf-col
Dave Griffiths's avatar
Dave Griffiths committed
608
    (list
609
     (mtitle "title" "Event: Pup found food")
Dave Griffiths's avatar
Dave Griffiths committed
610
611
     (mtext "text" "Food size")
     (horiz
612
613
614
615
616
617
      (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
618
                 (list (replace-fragment (get-id "event-holder") "events")))))))
Dave Griffiths's avatar
Dave Griffiths committed
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633

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


  (fragment
   "ev-pupcare"
   (linear-layout
634
    (make-id "") 'vertical fillwrap pf-col
Dave Griffiths's avatar
Dave Griffiths committed
635
    (list
636
     (mtitle "title" "Event: Pup is cared for")
Dave Griffiths's avatar
Dave Griffiths committed
637
638
639
     (build-grid-selector "pf-pupcare-who" "single" "Who cared for the pup?")
     (mtext "text" "Type of care")
     (horiz
640
641
642
643
644
645
646
      (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
647
                 (list (replace-fragment (get-id "event-holder") "events")))))))
Dave Griffiths's avatar
Dave Griffiths committed
648
649
650
651
652
653
654

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
      (populate-grid-selector
       "pf-pupcare-who" "single"
655
       (db-mongooses-by-pack)
Dave Griffiths's avatar
Dave Griffiths committed
656
       (lambda (individual)
657
         (entity-add-value! "id-who" "varchar" (ktv-get individual "unique_id"))
Dave Griffiths's avatar
Dave Griffiths committed
658
659
660
661
662
663
664
665
666
667
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "ev-pupaggr"
   (linear-layout
668
    (make-id "") 'vertical fillwrap pf-col
Dave Griffiths's avatar
Dave Griffiths committed
669
    (list
670
     (mtitle "title" "Event: Pup aggression")
Dave Griffiths's avatar
Dave Griffiths committed
671
672
673
     (build-grid-selector "pf-pupaggr-partner" "single" "Aggressive mongoose")

     (linear-layout
674
      (make-id "") 'horizontal (layout 'fill-parent 100 '1 'left 0) trans-col
Dave Griffiths's avatar
Dave Griffiths committed
675
676
677
      (list
       (vert
        (mtext "" "Fighting over")
678
679
680
        (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
681
682
       (vert
        (mtext "" "Level")
683
684
685
686
687
        (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)
688
                         (entity-add-value! "initiate" "varchar" (if v "yes" "no")) '()))
689
690
       (mtoggle-button "pf-pupaggr-win" "Win?"
                       (lambda (v)
691
                         (entity-add-value! "win" "varchar" (if v "yes" "no")) '()))))
692
693
694
695
     (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
696
                (list (replace-fragment (get-id "event-holder") "events"))))))
Dave Griffiths's avatar
Dave Griffiths committed
697
698
699
700
701
702
703

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
      (populate-grid-selector
       "pf-pupaggr-partner" "single"
704
       (db-mongooses-by-pack)
Dave Griffiths's avatar
Dave Griffiths committed
705
       (lambda (individual)
706
         (entity-add-value! "id-with" "varchar" (ktv-get individual "unique_id"))
Dave Griffiths's avatar
Dave Griffiths committed
707
708
709
710
711
712
713
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

714
715
716
717
718
719
720
721
722
723
724
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (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
725
      (make-id "") 'horizontal (layout 'fill-parent 80 '1 'left 0) trans-col
726
727
728
      (list
       (vert
        (mtext "text" "Outcome")
729
730
731
        (spinner (make-id "gp-int-out") (list "Retreat" "Advance" "Fight & retreat" "Fight & win") fillwrap
                 (lambda (v)
                   (entity-add-value! "outcome" "varchar" v) '())))
732
733
       (vert
        (mtext "text" "Duration")
734
735
736
737
738
        (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
739
                  (list (replace-fragment (get-id "event-holder") "events"))))))))
740
741
742
743
744
745
746
747

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
      (populate-grid-selector
       "gp-int-pack" "single"
       (db-all db "sync" "pack")
748
749
       (lambda (pack)
         (entity-add-value! "id-other-pack" "varchar" (ktv-get pack "unique_id"))
750
751
752
         (list)))
      (populate-grid-selector
       "gp-int-leader" "single"
753
       (db-mongooses-by-pack)
754
       (lambda (individual)
755
         (entity-add-value! "id-leader" "varchar" (ktv-get individual "unique_id"))
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
         (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
773
774
775
776
777
778
779
780
781
782
      (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
783
                (list (replace-fragment (get-id "event-holder") "events"))))))
784
785
786
787
788
789
790

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
      (populate-grid-selector
       "gp-alarm-caller" "single"
791
       (db-mongooses-by-pack)
792
       (lambda (individual)
793
         (entity-add-value! "id-caller" "varchar" (ktv-get individual "unique_id"))
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
         (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
809
      (make-id "") 'horizontal (layout 'fill-parent 90 '1 'left 0) trans-col
810
      (list
811
812
813
814
815
816
       (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)) '()))))
817
     (linear-layout
818
      (make-id "") 'horizontal (layout 'fill-parent 90 '1 'left 0) trans-col
819
820
821
      (list
       (vert
        (mtext "" "Where to")
822
823
824
825
826
        (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
827
                  (list (replace-fragment (get-id "event-holder") "events"))))))))
828
829
830
831
832
833
834

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
      (populate-grid-selector
       "gp-mov-leader" "single"
835
       (db-mongooses-by-pack)
836
       (lambda (individual)
837
         (entity-add-value! "id-leader" "varchar" (ktv-get individual "unique_id"))
838
839
840
841
842
843
844
845
846
847
848
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))



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

849
850


851

Dave Griffiths's avatar
Dave Griffiths committed
852
  (fragment
853
   "gc-start"
854
   (linear-layout
855
    (make-id "") 'vertical fillwrap gc-col
856
857
858
859
860
    (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) '()))
861
     (build-grid-selector "gc-start-present" "toggle" "Who's present?")))
862
863
864
865
866
867

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
      (populate-grid-selector
868
       "gc-start-present" "toggle"
869
       (db-mongooses-by-pack)
870
871
872
873
874
875
876
877
878
879
880
       (lambda (individual)
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "gc-weights"
   (linear-layout
881
    (make-id "") 'vertical fillwrap gc-col
882
883
    (list
     (mtitle "title" "Weights")
884
     (build-grid-selector "gc-weigh-choose" "toggle" "Choose mongoose")
885
     (edit-text (make-id "gc-weigh-weight") "" 20 "numeric" fillwrap (lambda (v) '()))
886
     (mtoggle-button "gc-weigh-accurate" "Accurate?" (lambda (v) '()))))
887
888
889
890
891
892

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
      (populate-grid-selector
893
       "gc-weigh-choose" "toggle"
894
       (db-mongooses-by-pack)
895
896
897
898
899
900
901
902
903
904
905
       (lambda (individual)
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "gc-preg"
   (linear-layout
906
    (make-id "") 'vertical fillwrap gc-col
907
908
    (list
     (mtitle "title" "Pregnant females")
909
     (build-grid-selector "gc-preg-choose" "toggle" "Choose")))
910
911
912
913
914

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
915
916
      (populate-grid-selector
       "gc-preg-choose" "toggle"
917
       (db-mongooses-by-pack)
918
919
920
921
922
923
924
925
       (lambda (individual)
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

926

927
928
929
  (fragment
   "gc-pup-assoc"
   (linear-layout
930
    (make-id "") 'vertical fillwrap gc-col
931
    (list
932
     (mtitle "title" "Pup Associations")
933
934
     (build-grid-selector "gc-pup-choose" "toggle" "Choose pup")
     (build-grid-selector "gc-pup-escort" "toggle" "Escort")))
935
936
937
938
939

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
940
941
      (populate-grid-selector
       "gc-pup-choose" "toggle"
942
       (db-mongooses-by-pack)
943
944
       (lambda (individual)
         (list)))
945
946
      (populate-grid-selector
       "gc-pup-escort" "toggle"
947
       (db-mongooses-by-pack)
948
949
950
951
952
953
954
955
956
957
958
       (lambda (individual)
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "gc-oestrus"
   (linear-layout
959
    (make-id "") 'vertical fillwrap gc-col
960
961
962
963
964
965
966
967
968
969
970
971
972
973
    (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
974
    (make-id "") 'vertical fillwrap gc-col
975
976
977
978
979
980
981
982
983
984
    (list
     (mtext "" "Babysittings...")))
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))
985

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

1001
1002


Dave Griffiths's avatar
Dave Griffiths committed
1003
1004
  )

1005
1006
1007
1008
(msg "one")

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

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

Dave Griffiths's avatar
Dave Griffiths committed
1030

1031
1032
1033
  (activity
   "main"
   (vert
Dave Griffiths's avatar
Dave Griffiths committed
1034
1035
    (text-view (make-id "main-title") "Mongoose 2000" 40 fillwrap)
    (text-view (make-id "main-about") "Advanced mongoose technology" 20 fillwrap)
1036
    (spacer 10)
1037
1038
1039
1040
    (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 "")))))
1041
    (mtext "foo" "Your ID")
Dave Griffiths's avatar
Dave Griffiths committed
1042
    (edit-text (make-id "main-id-text") "" 30 "text" fillwrap
1043
1044
1045
1046
               (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
1047
1048
    (mtext "foo" "Database")
    (horiz
1049
1050
     (mbutton2 "main-send" "Email" (lambda () (list)))
     (mbutton2 "main-sync" "Sync" (lambda () (list (start-activity "sync" 0 ""))))))
Dave Griffiths's avatar
Dave Griffiths committed
1051
1052
   (lambda (activity arg)
     (activity-layout activity))
1053
1054
1055
1056
1057
   (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
1058
1059
1060
1061
1062
1063
1064
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity requestcode resultcode) '()))

  (activity
1065
   "observations"
Dave Griffiths's avatar
Dave Griffiths committed
1066
   (vert
1067
1068
1069
    (text-view (make-id "title") "Start Observation" 40 fillwrap)
    (vert
     (mtext "type" "Choose observation type")
1070
     (horiz
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
      (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"))))))))
1092
    (build-grid-selector "choose-obs-pack-selector" "single" "Choose pack")
1093
1094
1095
    (mbutton
     "choose-obs-start" "Start"
     (lambda ()
1096
1097
1098
1099
1100
1101
1102
       ;; 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)
1103
             (else '())))))
1104
1105

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

1138

Dave Griffiths's avatar
Dave Griffiths committed
1139
  (activity
1140
   "group-composition"
Dave Griffiths's avatar
Dave Griffiths committed
1141
1142
1143
1144
1145
1146
1147
1148
1149
    (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
1150
1151
   (lambda (activity arg)
     (activity-layout activity))
1152
   (lambda (activity arg)
1153
     (msg (get-current 'observation-fragments '()))
1154
     (list
1155
1156
1157
1158
1159
1160
1161
      (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)
1162
                          (msg "button-bar" frag)
1163
1164
1165
1166
1167
1168
1169
                          (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
1170
                                 (replace-fragment (get-id "gc-top") (cadr frag))))))))
1171
                        (get-current 'observation-fragments '()))))
1172
1173
1174
1175
      (update-widget 'text-view (get-id "obs-title") 'text
                     (string-append
                      (get-current 'observation "No observation")
                      " with " (ktv-get (get-current 'pack '()) "name")))
1176
      ))
Dave Griffiths's avatar
Dave Griffiths committed
1177
1178
1179
1180
1181
1182
1183
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity requestcode resultcode) '()))

  (activity
1184
   "pup-focal-start"
1185
   (linear-layout
1186
    0 'vertical fillwrap pf-bgcol
1187
1188
1189
1190
1191
1192
    (list
     (vert
      (mtitle "" "Pup focal setup")
      (mtext "pf1-pack" "Pack")
      (build-grid-selector "pf1-grid" "single" "Select pup")
      (horiz
1193
1194
1195
1196
1197
1198
       (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) '()))
1199
1200
      (mbutton "pf1-done" "Done"
               (lambda ()
1201
                 (set-current! 'pup-focal-id (entity-record-values db "stream" "pup-focal"))
Dave Griffiths's avatar
Dave Griffiths committed
1202
1203
                 (set-current! 'timer-minutes 20)
                 (set-current! 'timer-seconds 59)
1204
1205
                 (list
                  (start-activity "pup-focal" 2 ""))))
1206
      )))
Dave Griffiths's avatar
Dave Griffiths committed
1207
1208
   (lambda (activity arg)
     (activity-layout activity))
1209
1210
   (lambda (activity arg)
     (list
1211
1212
      (populate-grid-selector
       "pf1-grid" "single"
1213
       (db-mongooses-by-pack)