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

16 17 18 19 20
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; strings

(define obs-gc "Group Composition")
(define obs-pf "Pup Focal")
21 22
(define obs-gp "Group Events")

23 24 25 26 27 28 29 30 31 32 33 34
(define entity-types
  (list
   "pup-focal"
   "pup-focal-nearest"
   "pup-focal-pupfeed"
   "pup-focal-pupfind"
   "pup-focal-pupcare"
   "pup-focal-pupaggr"
   "group-interaction"
   "group-alarm"
   "group-move"))

35 36
;; colours

37 38 39 40 41 42 43 44 45 46 47 48
(define pf-col (list 255 204 51 255))
(define gp-col (list 255 102 0 255))
(define gc-col (list 164 82 9 255))

(define pf-bgcol (list 255 204 51 127))
(define gp-bgcol (list 255 102 0 127))
(define gc-bgcol (list 164 82 9 127))

;(define pf-col (list  22  19 178  127))
;(define gp-col (list 255  97   0  127))
;(define gc-col (list 255 236   0  127))

49 50 51


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

(define (get-fragment-index name frag)
  (define (_ i l)
    (cond
     ((null? l) 0)
     ((equal? name (cadr (car l))) i)
     (else (_ (+ i 1) (cdr l)))))
  (_ 0 frag))

(define gc-fragments
  (list
   (list "Start" "gc-start")
   (list "Weights" "gc-weights")
   (list "Pregnant" "gc-preg")
66
   (list "Pup assoc" "gc-pup-assoc")
67 68 69 70
   (list "Oestrus" "gc-oestrus")
   (list "Babysit" "gc-babysitting")
   (list "End" "gc-end")))

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

(define (entity-reset!)
  (set-current! 'entity-values '()))

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

Dave Griffiths's avatar
Dave Griffiths committed
175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; syncing code

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

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

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

(define (build-url-from-entity table e)
  (string-append
   url
   "fn=sync"
   "&table=" table
   "&entity-type=" (list-ref (car e) 0)
   "&unique-id=" (list-ref (car e) 1)
Dave Griffiths's avatar
Dave Griffiths committed
196 197
   "&dirty=" (number->string (list-ref (car e) 2))
   "&version=" (number->string (list-ref (car e) 3))
Dave Griffiths's avatar
Dave Griffiths committed
198 199 200 201 202 203 204 205 206 207 208 209
   (build-url-from-ktvlist (cadr e))))

;; spit all dirty entities to server
(define (spit-dirty db table)
  (map
   (lambda (e)
     (http-request
      (string-append "req-" (list-ref (car e) 1))
      (build-url-from-entity table e)
      (lambda (v)
        (display v)(newline)
        (if (equal? (car v) "inserted")
Dave Griffiths's avatar
Dave Griffiths committed
210 211 212 213
            (begin
              (update-entity-clean db table (cadr v))
              (toast "Uploaded " (ktv-get (cadr e) "name")))
            (toast "Problem uploading " (ktv-get (cadr e) "name"))))))
214
   (dirty-entities db table)))
Dave Griffiths's avatar
Dave Griffiths committed
215

216
(define (suck-entity-from-server db table unique-id exists)
Dave Griffiths's avatar
Dave Griffiths committed
217 218 219 220 221 222 223
  ;; ask for the current version
  (http-request
   (string-append unique-id "-update-new")
   (string-append url "fn=entity&table=" table "&unique-id=" unique-id)
   (lambda (data)
     (msg "data from server request" data)
     ;; check "sync-insert" in sync.ss raspberry pi-side for the contents of 'entity'
224 225
     (let ((entity (list-ref data 0))
           (ktvlist (list-ref data 1)))
Dave Griffiths's avatar
Dave Griffiths committed
226
       (if (not exists)
227 228 229 230 231 232 233 234
           (begin
             (insert-entity-wholesale
              db table
              (list-ref entity 0) ;; entity-type
              (list-ref entity 1) ;; unique-id
              0 ;; dirty
              (list-ref entity 2) ;; version
              ktvlist))
Dave Griffiths's avatar
Dave Griffiths committed
235 236
           (update-to-version
            db table (get-entity-id db table unique-id)
Dave Griffiths's avatar
Dave Griffiths committed
237 238 239 240
            (list-ref entity 4) ktvlist))
       (list
        (update-widget 'text-view (get-id "sync-dirty") 'text (build-dirty))
        (toast (string-append "Downloaded " (ktv-get ktvlist "name"))))))))
Dave Griffiths's avatar
Dave Griffiths committed
241

Dave Griffiths's avatar
Dave Griffiths committed
242
;; repeatedly read version and request updates
Dave Griffiths's avatar
Dave Griffiths committed
243
(define (suck-new db table)
Dave Griffiths's avatar
Dave Griffiths committed
244 245 246
  (list
   (http-request
    "new-entities-req"
247
    (string-append url "fn=entity-versions&table=" table)
Dave Griffiths's avatar
Dave Griffiths committed
248
    (lambda (data)
Dave Griffiths's avatar
Dave Griffiths committed
249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268
      (let ((r (foldl
                (lambda (i r)
                  (let* ((unique-id (car i))
                         (version (cadr i))
                         (exists (entity-exists? db table unique-id))
                         (old
                          (if exists
                              (> version (get-entity-version
                                          db table
                                          (get-entity-id db table unique-id)))
                              #f)))
                    ;; if we don't have this entity or the version on the server is newer
                    (if (or (not exists) old)
                        (cons (suck-entity-from-server db table unique-id exists) r)
                        r)))
                '()
                data)))
        (if (null? r)
            (cons (toast "All files up to date") r)
            (cons (toast "Requesting " (length r) " entities") r)))))))
Dave Griffiths's avatar
Dave Griffiths committed
269

270 271 272 273 274 275 276 277 278
(define (build-dirty)
  (let ((sync (get-dirty-stats db "sync"))
        (stream (get-dirty-stats db "stream")))
    (msg sync stream)
    (string-append
     "Pack data: " (number->string (car sync)) "/" (number->string (cadr sync)) " "
     "Focal data: " (number->string (car stream)) "/" (number->string (cadr stream)))))


Dave Griffiths's avatar
Dave Griffiths committed
279
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
280
;; user interface abstraction
Dave Griffiths's avatar
Dave Griffiths committed
281

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

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

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

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

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

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

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

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

311 312 313 314 315 316 317
(define (mclear-toggles-not-me me id-list)
  (foldl
   (lambda (id r)
     (if (equal? me id)
         r (cons (update-widget 'toggle-button (get-id id) 'checked 0) r)))
   '() id-list))

318 319 320 321 322 323 324 325 326 327
(define (xwise n l)
  (define (_ c l)
    (cond
      ((null? l) (if (null? c) '() (list c)))
      ((eqv? (length c) (- n 1))
       (cons (append c (list (car l))) (_ '() (cdr l))))
      (else
       (_ (append c (list (car l))) (cdr l)))))
  (_ '() l))

328 329
;;;;

330
(define (build-grid-selector name type title)
331
  (vert
332
   (mtext "title" title)
333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348
   (linear-layout
    0 'horizontal
    (layout 'fill-parent 'fill-parent 1 'left 2) trans-col
    (list
     (image-view (make-id "im") "arrow_left" (layout 100 'fill-parent 1 'left 0))
     (scroll-view
      (make-id "scroller")
      (layout 'wrap-content 'wrap-content 1 'left 20)
      (list
       (linear-layout
        (make-id name) 'horizontal
        (layout 'wrap-content 'wrap-content 1 'centre 20) trans-col
        (list
         (button-grid (make-id name) type 3 20 (layout 100 40 1 'left 40)
                      (list) (lambda (v) '()))))))
     (image-view (make-id "im") "arrow_right" (layout 100 'fill-parent 1 'right 0))))))
349

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

354 355 356 357 358 359 360 361 362
(define (build-button-items name items)
  (map
   (lambda (item)
     (let ((item-name (fast-get-name item)))
       (list (make-id (string-append name item-name))
             item
             item-name)))
   items))

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

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

393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414
(define (timer-cb)
  (set-current!
   'timer-seconds
   (- (get-current 'timer-seconds 59) 1))
  (append
   (cond
    ((< (get-current 'timer-seconds 59) 0)
     (set-current! 'timer-minutes (- (get-current 'timer-minutes 20) 1))
     (set-current! 'timer-seconds 59)
     (list
      (replace-fragment (get-id "pf-top") "pf-scan1")))
    (else '()))
   (list
    (delayed "timer" 1000 timer-cb)
    (update-widget
     'text-view (get-id "pf-timer-time-minutes") 'text
     (string-append (number->string (get-current 'timer-minutes 20))))
    (update-widget
     'text-view (get-id "pf-timer-time") 'text
     (string-append (number->string (get-current 'timer-seconds 59))))
    )))

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

(define-fragment-list

420 421 422
  (fragment
   "pf-timer"
   (linear-layout
423
    (make-id "") 'vertical fillwrap trans-col
424
    (list
425
     (mtitle "pf-details" "Pack: xxx Pup: xxx")))
426 427 428
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
429 430 431 432 433 434
     (list
      (update-widget 'text-view (get-id "pf-details") 'text
                     (string-append
                      "Pack: " (ktv-get (get-current 'pack '()) "name") " "
                      "Pup: " (ktv-get (get-current 'individual '()) "name"))
                     )))
435 436 437 438 439 440 441
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


  (fragment
442
   "events"
443
   (linear-layout
444
    0 'vertical fillwrap trans-col
445
    (list
446
     (linear-layout
447
      (make-id "ev-pf") 'vertical wrapfill pf-col
448
      (list
449 450 451 452 453 454
       (mtitle "ev-pf-text" "Pup Focal Events")
       (horiz
        (mbutton2 "evb-pupfeed" "Pup Feed" (lambda () (list (replace-fragment (get-id "pf-bot") "ev-pupfeed"))))
        (mbutton2 "evb-pupfind" "Pup Find" (lambda () (list (replace-fragment (get-id "pf-bot") "ev-pupfind"))))
        (mbutton2 "evb-pupcare" "Pup Care" (lambda () (list (replace-fragment (get-id "pf-bot") "ev-pupcare"))))
        (mbutton2 "evb-pupagg" "Pup Aggression" (lambda () (list (replace-fragment (get-id "pf-bot") "ev-pupaggr")))))))
455
     (linear-layout
456
      (make-id "ev-pf") 'vertical fill gp-col
457
      (list
458 459 460 461 462
       (mtitle "text" "Group Events")
       (horiz
        (mbutton2 "evb-grpint" "Interaction" (lambda () (list (replace-fragment (get-id "pf-bot") "ev-grpint"))))
        (mbutton2 "evb-grpalarm" "Alarm" (lambda () (list (replace-fragment (get-id "pf-bot") "ev-grpalarm"))))
        (mbutton2 "evb-grpmov" "Movement" (lambda () (list (replace-fragment (get-id "pf-bot") "ev-grpmov")))))))))
463 464 465
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
466 467 468 469 470 471 472
     (if (equal? (get-current 'observation "none") obs-gp)
         (list
          (update-widget 'text-view (get-id "ev-pf-text") 'hide 0)
          (update-widget 'linear-layout (get-id "ev-pf") 'hide 0))
         (list
          (update-widget 'text-view (get-id "ev-pf-text") 'show 0)
          (update-widget 'linear-layout (get-id "ev-pf") 'show 0))))
473 474 475 476
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))
477

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

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


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

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
      (populate-grid-selector
       "pf-pupfeed-who" "single"
       (db-all-where db "sync" "mongoose"
                     (list "pack-id" (ktv-get (get-current 'pack '()) "unique_id")))
       (lambda (individual)
544
         (entity-add-value! "id-who" "varchar" (ktv-get individual "unique_id"))
545 546 547 548 549 550 551
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

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

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


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

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
      (populate-grid-selector
       "pf-pupcare-who" "single"
       (db-all-where db "sync" "mongoose"
                     (list "pack-id" (ktv-get (get-current 'pack '()) "unique_id")))
       (lambda (individual)
606
         (entity-add-value! "id-who" "varchar" (ktv-get individual "unique_id"))
Dave Griffiths's avatar
Dave Griffiths committed
607 608 609 610 611 612 613 614 615 616
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

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

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

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
      (populate-grid-selector
       "pf-pupaggr-partner" "single"
       (db-all-where db "sync" "mongoose"
                     (list "pack-id" (ktv-get (get-current 'pack '()) "unique_id")))
       (lambda (individual)
656
         (entity-add-value! "id-with" "varchar" (ktv-get individual "unique_id"))
Dave Griffiths's avatar
Dave Griffiths committed
657 658 659 660 661 662 663
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

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

  (fragment
   "ev-grpint"
   (linear-layout
    (make-id "") 'vertical fillwrap gp-col
    (list
     (mtitle "title" "Event: Group Interaction")
     (build-grid-selector "gp-int-pack" "single" "Inter-group interaction: Other pack identity")
     (build-grid-selector "gp-int-leader" "single" "Leader")
     (linear-layout
675
      (make-id "") 'horizontal (layout 'fill-parent 80 '1 'left 0) trans-col
676 677 678
      (list
       (vert
        (mtext "text" "Outcome")
679 680 681
        (spinner (make-id "gp-int-out") (list "Retreat" "Advance" "Fight & retreat" "Fight & win") fillwrap
                 (lambda (v)
                   (entity-add-value! "outcome" "varchar" v) '())))
682 683
       (vert
        (mtext "text" "Duration")
684 685 686 687 688 689
        (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")
                  (list (replace-fragment (get-id "pf-bot") "events"))))))))
690 691 692 693 694 695 696 697

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
      (populate-grid-selector
       "gp-int-pack" "single"
       (db-all db "sync" "pack")
698 699
       (lambda (pack)
         (entity-add-value! "id-other-pack" "varchar" (ktv-get pack "unique_id"))
700 701 702 703 704 705
         (list)))
      (populate-grid-selector
       "gp-int-leader" "single"
       (db-all-where db "sync" "mongoose"
                     (list "pack-id" (ktv-get (get-current 'pack '()) "unique_id")))
       (lambda (individual)
706
         (entity-add-value! "id-leader" "varchar" (ktv-get individual "unique_id"))
707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


  (fragment
   "ev-grpalarm"
   (linear-layout
    (make-id "") 'vertical fillwrap gp-col
    (list
     (mtitle "title" "Event: Group alarm")
     (build-grid-selector "gp-alarm-caller" "single" "Alarm caller")
     (mtext "text" "Cause")
     (horiz
724 725 726 727 728 729 730 731 732 733 734
      (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")
                (list (replace-fragment (get-id "pf-bot") "events"))))))
735 736 737 738 739 740 741 742 743 744

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
      (populate-grid-selector
       "gp-alarm-caller" "single"
       (db-all-where db "sync" "mongoose"
                     (list "pack-id" (ktv-get (get-current 'pack '()) "unique_id")))
       (lambda (individual)
745
         (entity-add-value! "id-caller" "varchar" (ktv-get individual "unique_id"))
746 747 748 749 750 751 752 753 754 755 756 757 758 759 760
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "ev-grpmov"
   (linear-layout
    (make-id "") 'vertical fillwrap gp-col
    (list
     (mtitle "title" "Event: Group movement")
     (build-grid-selector "gp-mov-leader" "single" "Leader")
     (linear-layout
761
      (make-id "") 'horizontal (layout 'fill-parent 90 '1 'left 0) trans-col
762
      (list
763 764 765 766 767 768
       (medit-text "gp-mov-w" "Width" "numeric"
                   (lambda (v) (entity-add-value! "pack-width" "int" (string->number v)) '()))
       (medit-text "gp-mov-l" "Length" "numeric"
                   (lambda (v) (entity-add-value! "pack-height" "int" (string->number v)) '()))
       (medit-text "gp-mov-l" "How many" "numeric"
                   (lambda (v) (entity-add-value! "pack-count" "int" (string->number v)) '()))))
769
     (linear-layout
770
      (make-id "") 'horizontal (layout 'fill-parent 90 '1 'left 0) trans-col
771 772 773
      (list
       (vert
        (mtext "" "Where to")
774 775 776 777 778 779
        (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")
                  (list (replace-fragment (get-id "pf-bot") "events"))))))))
780 781 782 783 784 785 786 787 788 789

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
      (populate-grid-selector
       "gp-mov-leader" "single"
       (db-all-where db "sync" "mongoose"
                     (list "pack-id" (ktv-get (get-current 'pack '()) "unique_id")))
       (lambda (individual)
790
         (entity-add-value! "id-leader" "varchar" (ktv-get individual "unique_id"))
791 792 793 794 795 796 797 798 799 800 801
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))



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

802 803


804

Dave Griffiths's avatar
Dave Griffiths committed
805
  (fragment
806
   "gc-start"
807
   (linear-layout
808
    (make-id "") 'vertical fillwrap gc-col
809 810 811 812 813
    (list
     (mtitle "title" "Start")
     (mtoggle-button "gc-start-main-obs" "Main observer" (lambda (v) '()))
     (mtext "" "Code")
     (edit-text (make-id "gc-start-code") "" 20 "numeric" fillwrap (lambda (v) '()))
814
     (build-grid-selector "gc-start-present" "toggle" "Who's present?")))
815 816 817 818 819 820

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
      (populate-grid-selector
821
       "gc-start-present" "toggle"
822 823 824 825 826 827 828 829 830 831 832 833 834
       (db-all-where db "sync" "mongoose"
                     (list "pack-id" (ktv-get (get-current 'pack '()) "unique_id")))
       (lambda (individual)
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "gc-weights"
   (linear-layout
835
    (make-id "") 'vertical fillwrap gc-col
836 837
    (list
     (mtitle "title" "Weights")
838
     (build-grid-selector "gc-weigh-choose" "toggle" "Choose mongoose")
839
     (edit-text (make-id "gc-weigh-weight") "" 20 "numeric" fillwrap (lambda (v) '()))
840
     (mtoggle-button "gc-weigh-accurate" "Accurate?" (lambda (v) '()))))
841 842 843 844 845 846

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
      (populate-grid-selector
847
       "gc-weigh-choose" "toggle"
848 849 850 851 852 853 854 855 856 857 858 859 860 861
       (db-all-where
        db "sync" "mongoose"
        (list "pack-id" (ktv-get (get-current 'pack '()) "unique_id")))
       (lambda (individual)
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "gc-preg"
   (linear-layout
862
    (make-id "") 'vertical fillwrap gc-col
863 864
    (list
     (mtitle "title" "Pregnant females")
865
     (build-grid-selector "gc-preg-choose" "toggle" "Choose")))
866 867 868 869 870

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
871 872
      (populate-grid-selector
       "gc-preg-choose" "toggle"
873 874 875 876 877 878 879 880 881 882 883
       (db-all-where
        db "sync" "mongoose"
        (list "pack-id" (ktv-get (get-current 'pack '()) "unique_id")))
       (lambda (individual)
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

884

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

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list
898 899
      (populate-grid-selector
       "gc-pup-choose" "toggle"
900 901 902 903 904
       (db-all-where
        db "sync" "mongoose"
        (list "pack-id" (ktv-get (get-current 'pack '()) "unique_id")))
       (lambda (individual)
         (list)))
905 906
      (populate-grid-selector
       "gc-pup-escort" "toggle"
907 908 909 910 911 912 913 914 915 916 917 918 919 920
       (db-all-where
        db "sync" "mongoose"
        (list "pack-id" (ktv-get (get-current 'pack '()) "unique_id")))
       (lambda (individual)
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "gc-oestrus"
   (linear-layout
921
    (make-id "") 'vertical fillwrap gc-col
922 923 924 925 926 927 928 929 930 931 932 933 934 935
    (list
     (mtext "" "Oestrus...")))
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "gc-babysitting"
   (linear-layout
936
    (make-id "") 'vertical fillwrap gc-col
937 938 939 940 941 942 943 944 945 946
    (list
     (mtext "" "Babysittings...")))
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))
947

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

963 964


Dave Griffiths's avatar
Dave Griffiths committed
965 966
  )

967 968 969 970
(msg "one")

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

972
(define-activity-list
973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990
;  (activity
;   "splash"
;   (vert
;    (text-view (make-id "splash-title") "Mongoose 2000" 40 fillwrap)
;    (mtext "splash-about" "Advanced mongoose technology")
;    (spacer 20)
;    (mbutton2 "f2" "Get started!" (lambda () (list (start-activity-goto "main" 2 ""))))
;    )
;
;   (lambda (activity arg)
;     (activity-layout activity))
;   (lambda (activity arg)
;     (list))
;   (lambda (activity) '())
;   (lambda (activity) '())
;   (lambda (activity) '())
;   (lambda (activity) '())
;   (lambda (activity requestcode resultcode) '()))
991

Dave Griffiths's avatar
Dave Griffiths committed
992

993 994 995
  (activity
   "main"
   (vert
Dave Griffiths's avatar
Dave Griffiths committed
996 997
    (text-view (make-id "main-title") "Mongoose 2000" 40 fillwrap)
    (text-view (make-id "main-about") "Advanced mongoose technology" 20 fillwrap)
998
    (spacer 10)
999 1000 1001 1002
    (horiz
     (mbutton2 "main-observations" "Observations" (lambda () (list (start-activity "observations" 2 ""))))
     (mbutton2 "main-manage" "Manage Packs" (lambda () (list (start-activity "manage-packs" 2 ""))))
     (mbutton2 "main-tag" "Tag Location" (lambda () (list (start-activity "tag-location" 2 "")))))
1003
    (mtext "foo" "Your ID")
Dave Griffiths's avatar
Dave Griffiths committed
1004
    (edit-text (make-id "main-id-text") "" 30 "text" fillwrap
1005 1006 1007 1008
               (lambda (v)
                 (set-current! 'user-id v)
                 (update-entity
                  db "local" 1 (list (ktv "user-id" "varchar" v)))))
Dave Griffiths's avatar
Dave Griffiths committed
1009 1010
    (mtext "foo" "Database")
    (horiz
1011 1012
     (mbutton2 "main-send" "Email" (lambda () (list)))
     (mbutton2 "main-sync" "Sync" (lambda () (list (start-activity "sync" 0 ""))))))
Dave Griffiths's avatar
Dave Griffiths committed
1013 1014
   (lambda (activity arg)
     (activity-layout activity))
1015 1016 1017 1018 1019
   (lambda (activity arg)
     (let ((user-id (ktv-get (get-entity db "local" 1) "user-id")))
       (set-current! 'user-id user-id)
       (list
        (update-widget 'edit-text (get-id "main-id-text") 'text user-id))))
Dave Griffiths's avatar
Dave Griffiths committed
1020 1021 1022 1023 1024 1025 1026
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity requestcode resultcode) '()))

  (activity
1027
   "observations"
Dave Griffiths's avatar
Dave Griffiths committed
1028
   (vert
1029 1030 1031
    (text-view (make-id "title") "Start Observation" 40 fillwrap)
    (vert
     (mtext "type" "Choose observation type")
1032
     (horiz
1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053
      (linear-layout
       0 'vertical wrap gc-col
       (list
        (mtoggle-button2 "choose-obs-gc" obs-gc
                         (lambda (v)
                           (set-current! 'observation obs-gc)
                           (mclear-toggles (list "choose-obs-pf" "choose-obs-gp"))))))
      (linear-layout
       0 'vertical wrap pf-col
       (list
        (mtoggle-button2 "choose-obs-pf" obs-pf
                         (lambda (v)
                           (set-current! 'observation obs-pf)
                           (mclear-toggles (list "choose-obs-gc" "choose-obs-gp"))))))
      (linear-layout
       0 'vertical wrap gp-col
       (list
        (mtoggle-button2 "choose-obs-gp" obs-gp
                         (lambda (v)
                           (set-current! 'observation obs-gp)
                           (mclear-toggles (list "choose-obs-pf" "choose-obs-gc"))))))))
1054
    (build-grid-selector "choose-obs-pack-selector" "single" "Choose pack")
1055 1056 1057
    (mbutton
     "choose-obs-start" "Start"
     (lambda ()
1058 1059 1060 1061 1062 1063 1064
       ;; set up the observation fragments
       (let ((obs (get-current 'observation "none")))
         (when (not (equal? obs "none"))
           (set-current!
            'observation-fragments
            (cond
             ((equal? obs obs-gc) gc-fragments)
1065
             (else '())))))
1066 1067

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