starwisp.scm 59.6 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
(define (date-time->string dt)
140
141
142
  (string-append
   (number->string (list-ref dt 0)) "-"
   (number->string (list-ref dt 1)) "-"
143
   (number->string (list-ref dt 2)) " "
144
145
   (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
  ;; standard bits
  (entity-add-value! "user" "varchar" (get-current 'user-id "none"))
152
  (entity-add-value! "time" "varchar" (date-time->string (date-time)))
153
154
  (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
(define (spit db table entities)
  (foldl
   (lambda (e r)
219
     (debug! (string-append "Sending a " (car (car e)) " to Raspberry Pi"))
220
221
222
223
224
225
226
227
228
229
     (append
      (list
       (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))
230
            (debug! (string-append "Uploaded " (car (car e)))))
231
           ((equal? (car v) "no change")
232
            (debug! (string-append "No change for " (car (car e)))))
233
234
           ((equal? (car v) "updated")
            (update-entity-clean db table (cadr v))
235
            (debug! (string-append "Updated changed " (car (car e)))))
236
           (else
237
238
239
240
            (debug! (string-append
                     "Problem uploading "
                     (car (car e)) " : " (car v)))))
          (list))))
241
242
243
      r))
   '()
   entities))
244

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

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

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

315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
(define (upload-dirty db)
  (let ((r (append
            (spit db "sync" (dirty-entities db "sync"))
            (spit db "stream" (dirty-entities db "stream")))))
    (append (cond
             ((> (length r) 0)
              (debug! (string-append "Uploading " (number->string (/ (length r) 2)) " items..."))
              (list
               (toast "Uploading data...")))
             (else
              (debug! "No data changed to upload")
              (list
               (toast "No data changed to upload")))) r)))

(define (connect-to-net fn)
  (list
   (network-connect
    "network"
    "mongoose-web"
    (lambda (state)
      (debug! (string-append "Raspberry Pi connection state now: " state))
      (append
       (if (equal? state "Connected") (fn) '())
       (list
        ;;(update-widget 'text-view (get-id "sync-connect") 'text state)
        ))))))
341

Dave Griffiths's avatar
Dave Griffiths committed
342
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
343
;; user interface abstraction
Dave Griffiths's avatar
Dave Griffiths committed
344

Dave Griffiths's avatar
Dave Griffiths committed
345
346
347
(define (mbutton id title fn)
  (button (make-id id) title 20 fillwrap fn))

348
(define (mbutton2 id title fn)
349
  (button (make-id id) title 20 (layout 150 100 1 'centre 0) fn))
350

351
(define (mtoggle-button id title fn)
352
  (toggle-button (make-id id) title 20 (layout 'fill-parent 'wrap-content 1 'centre 0) "fancy" fn))
353

354
(define (mtoggle-button2 id title fn)
355
  (toggle-button (make-id id) title 20 (layout 150 100 1 'centre 0) "plain" fn))
356

Dave Griffiths's avatar
Dave Griffiths committed
357
358
(define (mtext id text)
  (text-view (make-id id) text 20 fillwrap))
359

360
361
362
(define (mtitle id text)
  (text-view (make-id id) text 40 fillwrap))

363
364
(define (medit-text id text type fn)
  (vert
365
366
   (mtext (string-append id "-title") text)
   (edit-text (make-id id) "" 20 type fillwrap fn)))
367
368
369
370
371
372
373

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

374
375
376
377
378
379
380
(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))

381
382
383
384
385
386
387
388
389
390
(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))

391
392
;;;;

393
(define (build-grid-selector name type title)
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
  (linear-layout
   0 'vertical
   (layout 'fill-parent 'wrap-content 1 'left 0)
   (list 0 0 0 0)
   (list
    (mtext "title" title)
    (linear-layout
     0 'horizontal
     (layout 'fill-parent 'wrap-content 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)))))))
416

417
;; assumes grid selectors on mongeese only
418
419
420
(define (fast-get-name item)
  (list-ref (list-ref item 1) 2))

421
422
423
424
425
426
427
428
429
(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))

430
(define (populate-grid-selector name type items fn)
431
432
  (prof-start "popgrid")
  (prof-start "popgrid setup")
433
434
  (let ((id->items (build-button-items name items))
        (selected-set '()))
435
436
    (prof-end "popgrid setup")
    (let ((r (update-widget
437
438
     'button-grid (get-id name) 'grid-buttons
     (list
439
      type 3 20 (layout 100 40 1 'left 0)
440
441
442
443
      (map
       (lambda (ii)
         (list (car ii) (caddr ii)))
       id->items)
444
445
      (lambda (v state)
        (cond
446
447
         ((equal? type "toggle")
          ;; update list of selected items
448
449
450
451
452
453
454
455
456
457
          (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))
458
          (fn (cadr (findv v id->items))))))))))
459
460
461
462
      (prof-end "popgrid")
      r)))

(define (db-mongooses-by-pack)
463
  (db-all-where
464
465
   db "sync" "mongoose"
   (ktv "pack-id" "varchar" (ktv-get (get-current 'pack '()) "unique_id"))))
466

467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
(define (db-mongooses-by-pack-male)
  (db-all-where2
   db "sync" "mongoose"
   (ktv "pack-id" "varchar" (ktv-get (get-current 'pack '()) "unique_id"))
   (ktv "gender" "varchar" "Male")))

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


;; (y m d h m s)
(define (date-minus-months d ms)
  (let ((year (list-ref d 0))
        (month (- (list-ref d 1) 1)))
    (let ((new-month (- month ms)))
      (list
       (if (< new-month 0) (- year 1) year)
       (+ (if (< new-month 0) (+ new-month 12) new-month) 1)
       (list-ref d 2)
       (list-ref d 3)
       (list-ref d 4)
       (list-ref d 5)))))

(define (db-mongooses-by-pack-pups)
Dave Griffiths's avatar
Dave Griffiths committed
494
  (db-all-newer
495
496
497
498
   db "sync" "mongoose"
   (ktv "pack-id" "varchar" (ktv-get (get-current 'pack '()) "unique_id"))
   (ktv "dob" "varchar" (date->string (date-minus-months (date-time) 6)))))

499
500
501
502
503
504
(define (db-mongooses-by-pack-adults)
  (db-all-older
   db "sync" "mongoose"
   (ktv "pack-id" "varchar" (ktv-get (get-current 'pack '()) "unique_id"))
   (ktv "dob" "varchar" (date->string (date-minus-months (date-time) 6)))))

505
506
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
Dave Griffiths's avatar
Dave Griffiths committed
507

508
509
510
511
(define (debug! txt)
  (set-current! 'debug-text (string-append txt "\n" (get-current 'debug-text ""))))

(define (update-debug)
512
513
514
  (update-widget 'debug-text-view (get-id "sync-debug") 'text
                 (get-current 'debug-text "")))

515
516
517
518
519
(define (debug-timer-cb)
  (list
   (delayed "debug-timer" 1000 debug-timer-cb)
   (update-debug)))

520

521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
(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))))
    )))

543
544
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; fragments
Dave Griffiths's avatar
Dave Griffiths committed
545
546
547

(define-fragment-list

548
549
550
  (fragment
   "pf-timer"
   (linear-layout
551
    (make-id "") 'vertical fillwrap trans-col
552
    (list
553
     (mtitle "pf-details" "Pack: xxx Pup: xxx")))
554
555
556
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
557
558
559
560
561
562
     (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"))
                     )))
563
564
565
566
567
568
569
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


  (fragment
570
   "events"
571
   (linear-layout
572
    0 'vertical fillwrap trans-col
573
    (list
574
     (linear-layout
Dave Griffiths's avatar
Dave Griffiths committed
575
      (make-id "ev-pf") 'vertical fill pf-col
576
      (list
577
578
       (mtitle "ev-pf-text" "Pup Focal Events")
       (horiz
Dave Griffiths's avatar
Dave Griffiths committed
579
580
581
582
        (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")))))))
583
     (linear-layout
584
      (make-id "ev-pf") 'vertical fill gp-col
585
      (list
586
587
       (mtitle "text" "Group Events")
       (horiz
Dave Griffiths's avatar
Dave Griffiths committed
588
589
        (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"))))
590
591
        (mbutton2 "evb-grpmov" "Movement" (lambda () (list (replace-fragment (get-id "event-holder") "ev-grpmov"))))
        (mbutton2 "evb-grpnote" "Note" (lambda () (list (replace-fragment (get-id "event-holder") "note")))))))))
592
593
594
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
595
     (if (equal? (get-current 'observation "none") obs-pf)
596
597
         (list
          (update-widget 'text-view (get-id "ev-pf-text") 'show 0)
Dave Griffiths's avatar
Dave Griffiths committed
598
599
600
601
          (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))))
602
603
604
605
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))
606

607
608
609
  (fragment
   "pf-scan1"
   (linear-layout
610
    (make-id "") 'vertical fillwrap pf-col
611
    (list
612
613
614
     (mtext "title" "Nearest Neighbour Scan")
     (build-grid-selector "pf-scan-nearest" "single" "Closest Mongoose")
     (build-grid-selector "pf-scan-close" "toggle" "Mongooses within 2m")
615
616
617
618
     (mbutton "pf-scan-done" "Done"
              (lambda ()
                (entity-add-value! "parent" "varchar" (get-current 'pup-focal-id ""))
                (entity-record-values db "stream" "pup-focal-nearest")
619
                (list (replace-fragment (get-id "pf-top") "pf-timer"))))))
620
621
622
623

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
624
625
     (entity-reset!)
     (entity-add-value! "scan-time" "varchar" (date-time->string (date-time)))
626
     (list
627
628
      (play-sound "ping")
      (vibrate 300)
629
      (populate-grid-selector
630
       "pf-scan-nearest" "single"
631
       (db-mongooses-by-pack-adults)
632
633
       (lambda (individual)
         (entity-add-value! "id-nearest" "varchar" (ktv-get individual "unique_id"))
634
635
         (list)))
      (populate-grid-selector
636
       "pf-scan-close" "toggle"
637
       (db-mongooses-by-pack-adults)
638
639
       (lambda (individuals)
         (entity-add-value! "id-list-close" "varchar" (assemble-array individuals))
640
641
         (list)))
      ))
642
643
644
645
646
647
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


648
649
650
  (fragment
   "ev-pupfeed"
   (linear-layout
651
    (make-id "") 'vertical fillwrap pf-col
652
    (list
653
     (mtitle "title" "Event: Pup is fed")
654
655
656
     (build-grid-selector "pf-pupfeed-who" "single" "Who fed the pup?")
     (mtext "text" "Food size")
     (horiz
657
658
659
660
661
662
663
      (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")
664
665
666
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-pupfeed-cancel" "Cancel"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
667
                 (list (replace-fragment (get-id "event-holder") "events")))))))
668
669
670
671

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
672
     (entity-reset!)
673
674
675
     (list
      (populate-grid-selector
       "pf-pupfeed-who" "single"
676
       (db-mongooses-by-pack-adults)
677
       (lambda (individual)
678
         (entity-add-value! "id-who" "varchar" (ktv-get individual "unique_id"))
679
680
681
682
683
684
685
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

Dave Griffiths's avatar
Dave Griffiths committed
686
687
688
  (fragment
   "ev-pupfind"
   (linear-layout
689
    (make-id "") 'vertical fillwrap pf-col
Dave Griffiths's avatar
Dave Griffiths committed
690
    (list
691
     (mtitle "title" "Event: Pup found food")
Dave Griffiths's avatar
Dave Griffiths committed
692
     (mtext "text" "Food size")
693
694
     (spinner (make-id "pf-pupfind-size") (list "Small" "Medium" "Large") fillwrap
              (lambda (v) (entity-add-value! "size" "varchar" v) '()))
Dave Griffiths's avatar
Dave Griffiths committed
695
     (horiz
696
697
698
699
      (mbutton "pf-pupfind-done" "Done"
               (lambda ()
                 (entity-add-value! "parent" "varchar" (get-current 'pup-focal-id ""))
                 (entity-record-values db "stream" "pup-focal-pupfind")
700
701
702
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-pupfind-cancel" "Cancel"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
703
                 (list (replace-fragment (get-id "event-holder") "events")))))))
Dave Griffiths's avatar
Dave Griffiths committed
704
705
706
707

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
708
     (entity-reset!)
Dave Griffiths's avatar
Dave Griffiths committed
709
710
711
712
713
714
715
716
717
718
719
     (list
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


  (fragment
   "ev-pupcare"
   (linear-layout
720
    (make-id "") 'vertical fillwrap pf-col
Dave Griffiths's avatar
Dave Griffiths committed
721
    (list
722
     (mtitle "title" "Event: Pup is cared for")
Dave Griffiths's avatar
Dave Griffiths committed
723
724
725
     (build-grid-selector "pf-pupcare-who" "single" "Who cared for the pup?")
     (mtext "text" "Type of care")
     (horiz
726
727
728
729
730
731
732
      (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")
733
734
735
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-pupcare-cancel" "Cancel"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
736
                 (list (replace-fragment (get-id "event-holder") "events")))))))
Dave Griffiths's avatar
Dave Griffiths committed
737
738
739
740

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
741
     (entity-reset!)
Dave Griffiths's avatar
Dave Griffiths committed
742
743
744
     (list
      (populate-grid-selector
       "pf-pupcare-who" "single"
745
       (db-mongooses-by-pack-adults)
Dave Griffiths's avatar
Dave Griffiths committed
746
       (lambda (individual)
747
         (entity-add-value! "id-who" "varchar" (ktv-get individual "unique_id"))
Dave Griffiths's avatar
Dave Griffiths committed
748
749
750
751
752
753
754
755
756
757
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "ev-pupaggr"
   (linear-layout
758
    (make-id "") 'vertical fillwrap pf-col
Dave Griffiths's avatar
Dave Griffiths committed
759
    (list
760
     (mtitle "title" "Event: Pup aggression")
Dave Griffiths's avatar
Dave Griffiths committed
761
762
763
     (build-grid-selector "pf-pupaggr-partner" "single" "Aggressive mongoose")

     (linear-layout
764
      (make-id "") 'horizontal (layout 'fill-parent 100 '1 'left 0) trans-col
Dave Griffiths's avatar
Dave Griffiths committed
765
766
767
      (list
       (vert
        (mtext "" "Fighting over")
768
769
770
        (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
771
772
       (vert
        (mtext "" "Level")
773
774
775
776
777
        (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)
778
                         (entity-add-value! "initiate" "varchar" (if v "yes" "no")) '()))
779
780
       (mtoggle-button "pf-pupaggr-win" "Win?"
                       (lambda (v)
781
                         (entity-add-value! "win" "varchar" (if v "yes" "no")) '()))))
782
783
784
785
786
787
788
789
790
791
     (horiz
      (mbutton "pf-pupaggr-done" "Done"
               (lambda ()
                 (entity-add-value! "parent" "varchar" (get-current 'pup-focal-id ""))
                 (entity-record-values db "stream" "pup-focal-pupaggr")
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-pupaggr-cancel" "Cancel"
               (lambda ()
                 (list (replace-fragment (get-id "event-holder") "events")))))))

Dave Griffiths's avatar
Dave Griffiths committed
792
793
794
795

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
796
     (entity-reset!)
Dave Griffiths's avatar
Dave Griffiths committed
797
798
799
     (list
      (populate-grid-selector
       "pf-pupaggr-partner" "single"
800
       (db-mongooses-by-pack)
Dave Griffiths's avatar
Dave Griffiths committed
801
       (lambda (individual)
802
         (entity-add-value! "id-with" "varchar" (ktv-get individual "unique_id"))
Dave Griffiths's avatar
Dave Griffiths committed
803
804
805
806
807
808
809
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

810
811
812
813
814
815
816
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (fragment
   "ev-grpint"
   (linear-layout
    (make-id "") 'vertical fillwrap gp-col
    (list
817
     (mtext "title" "Event: Group Interaction")
818
819
820
     (build-grid-selector "gp-int-pack" "single" "Inter-group interaction: Other pack identity")
     (build-grid-selector "gp-int-leader" "single" "Leader")
     (linear-layout
821
      (make-id "") 'horizontal (layout 'fill-parent 80 '1 'left 0) trans-col
822
823
824
      (list
       (vert
        (mtext "text" "Outcome")
825
        (spinner (make-id "gp-int-out") (list "Retreat" "Advance" "Fight retreat" "Fight win") fillwrap
826
827
                 (lambda (v)
                   (entity-add-value! "outcome" "varchar" v) '())))
828
829
       (vert
        (mtext "text" "Duration")
830
831
832
833
834
        (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")
835
836
837
                  (list (replace-fragment (get-id "event-holder") "events"))))
       (mbutton "pf-grpint-cancel" "Cancel"
                (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
838
                  (list (replace-fragment (get-id "event-holder") "events"))))))))
839

840

841
842
843
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
844
     (entity-reset!)
845
846
847
848
     (list
      (populate-grid-selector
       "gp-int-pack" "single"
       (db-all db "sync" "pack")
849
850
       (lambda (pack)
         (entity-add-value! "id-other-pack" "varchar" (ktv-get pack "unique_id"))
851
852
853
         (list)))
      (populate-grid-selector
       "gp-int-leader" "single"
854
       (db-mongooses-by-pack)
855
       (lambda (individual)
856
         (entity-add-value! "id-leader" "varchar" (ktv-get individual "unique_id"))
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
         (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
874
875
876
877
878
879
880
      (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")) '())))
881
882
883
884
885
886
887
888
     (horiz
      (mbutton "pf-grpalarm-done" "Done"
               (lambda ()
                 (entity-record-values db "stream" "group-alarm")
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-grpalarm-cancel" "Cancel"
               (lambda ()
                 (list (replace-fragment (get-id "event-holder") "events")))))))
889
890
891
892

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
893
     (entity-reset!)
894
895
896
     (list
      (populate-grid-selector
       "gp-alarm-caller" "single"
897
       (db-mongooses-by-pack)
898
       (lambda (individual)
899
         (entity-add-value! "id-caller" "varchar" (ktv-get individual "unique_id"))
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
         (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
915
      (make-id "") 'horizontal (layout 'fill-parent 90 '1 'left 0) trans-col
916
      (list
Dave Griffiths's avatar
Dave Griffiths committed
917
       (medit-text "gp-mov-w" "Pack width" "numeric"
918
                   (lambda (v) (entity-add-value! "pack-width" "int" (string->number v)) '()))
Dave Griffiths's avatar
Dave Griffiths committed
919
920
921
       (medit-text "gp-mov-l" "Pack depth" "numeric"
                   (lambda (v) (entity-add-value! "pack-depth" "int" (string->number v)) '()))
       (medit-text "gp-mov-c" "How many mongooses?" "numeric"
922
                   (lambda (v) (entity-add-value! "pack-count" "int" (string->number v)) '()))))
923
     (linear-layout
924
      (make-id "") 'horizontal (layout 'fill-parent 'wrap-content '1 'left 0) trans-col
925
926
927
      (list
       (vert
        (mtext "" "Where to")
Dave Griffiths's avatar
Dave Griffiths committed
928
        (spinner (make-id "gp-mov-to") (list "Latrine" "Water" "Food" "Nothing" "Den" "Unknown") fillwrap
929
                 (lambda (v) (entity-add-value! "destination" "varchar" v)  '())))
930
931
932
933
934
935
936
937
       (horiz
        (mbutton "pf-grpmov-done" "Done"
                 (lambda ()
                   (entity-record-values db "stream" "group-move")
                   (list (replace-fragment (get-id "event-holder") "events"))))
        (mbutton "pf-grpalarm-cancel" "Cancel"
                 (lambda ()
                   (list (replace-fragment (get-id "event-holder") "events")))))))))
938
939
940
941

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
942
     (entity-reset!)
943
944
945
     (list
      (populate-grid-selector
       "gp-mov-leader" "single"
946
       (db-mongooses-by-pack)
947
       (lambda (individual)
948
         (entity-add-value! "id-leader" "varchar" (ktv-get individual "unique_id"))
949
950
951
952
953
954
955
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
  (fragment
   "note"
   (linear-layout
    (make-id "") 'vertical fillwrap gp-col
    (list
     (mtitle "title" "Make a note")
     (edit-text (make-id "note-text") "" 20 "text" fillwrap
                (lambda (v)
                  (entity-add-value! "text" "varchar" v)
                  '()))
     (horiz
      (mbutton "note-done" "Done"
               (lambda ()
                 (entity-record-values db "stream" "note")
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "note-cancel" "Cancel"
               (lambda ()
                 (entity-reset!)
                 (list (replace-fragment (get-id "event-holder") "events")))))))

   (lambda (fragment arg)
     (activity-layout fragment))
978
979
980
   (lambda (fragment arg)
     (entity-reset!)
     (list))
981
982
983
984
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))
985
986
987
988


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

989
990


991

Dave Griffiths's avatar
Dave Griffiths committed
992
  (fragment
993
   "gc-start"
994
   (linear-layout
995
    (make-id "") 'vertical fill gc-col
996
997
998
999
1000
    (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) '()))
1001
     (build-grid-selector "gc-start-present" "toggle" "Who's present?")))
1002
1003
1004
1005
1006
1007

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
      (populate-grid-selector
1008
       "gc-start-present" "toggle"
1009
       (db-mongooses-by-pack)
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
       (lambda (individual)
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "gc-weights"
   (linear-layout
1021
    (make-id "") 'vertical fill gc-col
1022
1023
    (list
     (mtitle "title" "Weights")
1024
     (build-grid-selector "gc-weigh-choose" "toggle" "Choose mongoose")
1025
     (edit-text (make-id "gc-weigh-weight") "" 20 "numeric" fillwrap (lambda (v) '()))
1026
     (mtoggle-button "gc-weigh-accurate" "Accurate?" (lambda (v) '()))))
1027
1028
1029
1030
1031
1032

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
      (populate-grid-selector
1033
       "gc-weigh-choose" "toggle"
1034
       (db-mongooses-by-pack)
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
       (lambda (individual)
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "gc-preg"
   (linear-layout
1046
    (make-id "") 'vertical fill gc-col
1047
1048
    (list
     (mtitle "title" "Pregnant females")
1049
     (build-grid-selector "gc-preg-choose" "toggle" "Choose")))
1050
1051
1052
1053
1054

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
1055
1056
      (populate-grid-selector
       "gc-preg-choose" "toggle"
1057
       (db-mongooses-by-pack-female)
1058
1059
1060
1061
1062
1063
1064
1065
       (lambda (individual)
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

1066

1067
1068
1069
  (fragment
   "gc-pup-assoc"
   (linear-layout
1070
    (make-id "") 'vertical fill gc-col
1071
    (list
1072
     (mtitle "title" "Pup Associations")
1073
1074
     (build-grid-selector "gc-pup-choose" "toggle" "Choose pup")
     (build-grid-selector "gc-pup-escort" "toggle" "Escort")))
1075
1076
1077
1078
1079

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
1080
1081
      (populate-grid-selector
       "gc-pup-choose" "toggle"
1082
       (db-mongooses-by-pack-pups)
1083
1084
       (lambda (individual)
         (list)))
1085
1086
      (populate-grid-selector
       "gc-pup-escort" "toggle"
1087
       (db-mongooses-by-pack-adults)
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
       (lambda (individual)
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "gc-oestrus"
   (linear-layout
1099
    (make-id "") 'vertical fill gc-col
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
    (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
1114
    (make-id "") 'vertical fill gc-col
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
    (list
     (mtext "" "Babysittings...")))
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))
1125

1126
1127
1128
  (fragment
   "gc-end"
   (linear-layout
1129
    (make-id "") 'vertical fill gc-col
1130
1131
    (list
     (mtext "" "end!...")))
Dave Griffiths's avatar
Dave Griffiths committed
1132
1133
   (lambda (fragment arg)
     (activity-layout fragment))
1134
1135
   (lambda (fragment arg)
     (list))
Dave Griffiths's avatar
Dave Griffiths committed
1136
1137
1138
1139
1140
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

1141
1142


Dave Griffiths's avatar
Dave Griffiths committed
1143
1144
  )

1145
1146
1147
1148
(msg "one")

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

1150
(define-activity-list
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
;  (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) '()))
1169

Dave Griffiths's avatar
Dave Griffiths committed
1170

1171
1172
1173
  (activity
   "main"
   (vert
Dave Griffiths's avatar
Dave Griffiths committed
1174
1175
    (text-view (make-id "main-title") "Mongoose 2000" 40 fillwrap)
    (text-view (make-id "main-about") "Advanced mongoose technology" 20 fillwrap)
1176
    (spacer 10)
1177
1178
1179
1180
    (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 "")))))
1181
    (mtext "foo" "Your ID")
Dave Griffiths's avatar
Dave Griffiths committed
1182
    (edit-text (make-id "main-id-text") "" 30 "text" fillwrap
1183
1184
1185
1186
               (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
1187
    (mtext "foo" "Database")
Dave Griffiths's avatar
Dave Griffiths committed
1188
    (mbutton2 "main-sync" "Sync" (lambda () (list (start-activity "sync" 0 "")))))
Dave Griffiths's avatar
Dave Griffiths committed
1189
1190
   (lambda (activity arg)
     (activity-layout activity))