starwisp.scm 69.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 37 38 39 40 41 42
(define pup-focal-export
  (list
   "pup-focal-nearest"
   "pup-focal-pupfeed"
   "pup-focal-pupfind"
   "pup-focal-pupcare"
   "pup-focal-pupaggr"))

43
(define list-sizes (list "Small" "Medium" "Large"))
44

45 46
;; colours

47 48 49 50 51 52 53 54 55 56 57 58
(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))

59 60 61


(define trans-col (list 0 0 0 0))
62 63 64 65 66 67 68 69 70 71 72 73 74 75

(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")
76
   (list "Pup assoc" "gc-pup-assoc")
77 78 79 80
   (list "Oestrus" "gc-oestrus")
   (list "Babysit" "gc-babysitting")
   (list "End" "gc-end")))

81
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Dave Griffiths's avatar
Dave Griffiths committed
82
;; persistent database
83

84
(define db "/sdcard/mongoose/local-mongoose.db")
85
(define main-db "/sdcard/mongoose/mongoose.db")
86

87 88 89 90 91 92 93 94 95 96 97 98 99
(define (setup-database!)
  (msg "setting up database")
  (db-close db) ;; close just in case (sorts out db file delete while running problem)
  (db-open db)
  (msg "setting up tables")
  (setup db "local")
  (setup db "sync")
  (setup db "stream")
  (msg (db-status db))
  (insert-entity-if-not-exists
   db "local" "app-settings" "null" 1
   (list
    (ktv "user-id" "varchar" "No name yet...")))
100
  (msg (db-all-sort-normal db "local" "app-settings")))
Dave Griffiths's avatar
Dave Griffiths committed
101

Dave Griffiths's avatar
Dave Griffiths committed
102
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
103
;; user interface abstraction
Dave Griffiths's avatar
Dave Griffiths committed
104

Dave Griffiths's avatar
Dave Griffiths committed
105
(define (mbutton id title fn)
106
  (button (make-id id) title 20 (layout 'fill-parent 'wrap-content 1 'centre 5) fn))
Dave Griffiths's avatar
Dave Griffiths committed
107

108
(define (mbutton2 id title fn)
109
  (button (make-id id) title 20 (layout 150 100 1 'centre 5) fn))
110

111
(define (mtoggle-button id title fn)
112
  (toggle-button (make-id id) title 20 (layout 'fill-parent 'wrap-content 1 'centre 5) "fancy" fn))
113

114
(define (mtoggle-button-yes id title fn)
115
  (toggle-button (make-id id) title 20 (layout 49 43 1 'centre 0) "yes" fn))
116 117

(define (mtoggle-button-maybe id title fn)
118
  (toggle-button (make-id id) title 20 (layout  49 43 1 'centre 0) "maybe" fn))
119 120

(define (mtoggle-button-no id title fn)
121
  (toggle-button (make-id id) title 20 (layout  49 43 1 'centre 0) "no" fn))
122

123
(define (mtoggle-button2 id title fn)
124
  (toggle-button (make-id id) title 20 (layout 150 100 1 'centre 5) "plain" fn))
125

Dave Griffiths's avatar
Dave Griffiths committed
126
(define (mtext id text)
127
  (text-view (make-id id) text 20 fillwrap))
128

129
(define (mtitle id text)
130
  (text-view (make-id id) text 40 fillwrap))
131

132 133
(define (medit-text id text type fn)
  (vert
134
   (mtext (string-append id "-title") text)
135
   (edit-text (make-id id) "" 20 type fillwrap fn)))
136

Dave Griffiths's avatar
Dave Griffiths committed
137 138 139
(define (medit-text-value id text value type fn)
  (vert
   (mtext (string-append id "-title") text)
140
   (edit-text (make-id id) value 20 type fillwrap fn)))
Dave Griffiths's avatar
Dave Griffiths committed
141

142 143 144 145 146 147
(define (mclear-toggles id-list)
  (map
   (lambda (id)
     (update-widget 'toggle-button (get-id id) 'checked 0))
   id-list))

148 149 150 151 152 153 154
(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))

155 156 157 158 159 160 161 162 163 164
(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))

165 166
;;;;

167
(define (build-grid-selector name type title)
168 169 170 171 172 173 174 175 176 177
  (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
178
      (image-view (make-id "im") "arrow_left" (layout 200 'fill-parent 1 'left 0))
179 180
      (scroll-view
       (make-id "scroller")
181
       (layout 'wrap-content 'wrap-content 1 'left 5)
182 183 184
       (list
        (linear-layout
         (make-id name) 'horizontal
185
         (layout 'wrap-content 'wrap-content 1 'centre 5) trans-col
186
         (list
187
          (button-grid (make-id name) type 3 20 (layout 100 60 1 'left 5)
188
                       (list) (lambda (v) '()))))))
189
      (image-view (make-id "im") "arrow_right" (layout 200 'fill-parent 1 'right 0)))))))
190

191
;; assumes grid selectors on mongeese only
192 193 194
(define (fast-get-name item)
  (list-ref (list-ref item 1) 2))

195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212
(define (build-button-items name items unknown)
  (append
   (map
    (lambda (item)
      (let ((item-name (fast-get-name item)))
        (list (make-id (string-append name item-name))
              item
              item-name)))
    items)
   (if unknown
       (list
        (list (make-id (string-append name "-unknown"))
              (list (ktv "name" "varchar" "Unknown")
                    (ktv "unique_id" "varchar" "Unknown"))
              "???"))
       '())))

(define (populate-grid-selector name type items unknown fn)
213 214
  (prof-start "popgrid")
  (prof-start "popgrid setup")
215
  (let ((id->items (build-button-items name items unknown))
216
        (selected-set '()))
217 218
    (prof-end "popgrid setup")
    (let ((r (update-widget
219 220
     'button-grid (get-id name) 'grid-buttons
     (list
221
      type 3 20 (layout 80 50 1 'left 2)
222 223
      (map
       (lambda (ii)
224
         (list (car ii) (caddr ii)))
225
       id->items)
226 227
      (lambda (v state)
        (cond
228 229
         ((equal? type "toggle")
          ;; update list of selected items
230 231 232 233 234 235 236 237 238
          (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
Dave Griffiths's avatar
Dave Griffiths committed
239
          ;;(msg (findv v id->items))
240
          (fn (cadr (findv v id->items))))))))))
241 242 243 244
      (prof-end "popgrid")
      r)))

(define (db-mongooses-by-pack)
245
  (db-all-where
246 247
   db "sync" "mongoose"
   (ktv "pack-id" "varchar" (ktv-get (get-current 'pack '()) "unique_id"))))
248

249 250 251 252 253 254
(define (db-mongooses-by-pack-ignore-delete)
  (db-all-where-ignore-delete
   db "sync" "mongoose"
   (ktv "pack-id" "varchar" (ktv-get (get-current 'pack '()) "unique_id"))))


255
(define (db-mongooses-by-pack-male)
256
  (db-all-where2or
257 258
   db "sync" "mongoose"
   (ktv "pack-id" "varchar" (ktv-get (get-current 'pack '()) "unique_id"))
259
   (ktv "gender" "varchar" "Male") "Unknown"))
260 261

(define (db-mongooses-by-pack-female)
262
  (db-all-where2or
263 264
   db "sync" "mongoose"
   (ktv "pack-id" "varchar" (ktv-get (get-current 'pack '()) "unique_id"))
265
   (ktv "gender" "varchar" "Female") "Unknown"))
266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281


;; (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
282
  (db-all-newer
283 284 285 286
   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)))))

287 288 289 290 291 292
(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)))))

293 294 295 296 297 298 299 300 301 302 303 304 305 306


(define (tri-state id text key)
  (linear-layout
   (make-id "") 'vertical (layout 'fill-parent 'wrap-content '1 'centre 0) trans-col
   (list
    (linear-layout
     (make-id "") 'horizontal (layout 'wrap-content 'wrap-parent '1 'centre 0) trans-col
     (list
      (mtoggle-button-yes
       (string-append id "-y") ""
       (lambda (v)
         (cond
          (v
Dave Griffiths's avatar
Dave Griffiths committed
307
           (entity-set-value! key "varchar" "yes")
308 309 310 311 312 313 314 315 316 317 318 319
           (list
            (update-widget 'toggle-button (get-id (string-append id "-n")) 'checked 0)
            (update-widget 'toggle-button (get-id (string-append id "-m")) 'checked 0)))
               (else
                (list
                 (update-widget 'toggle-button (get-id (string-append id "-y")) 'checked 1))))
              ))
      (mtoggle-button-maybe
       (string-append id "-m")  ""
       (lambda (v)
         (cond
          (v
Dave Griffiths's avatar
Dave Griffiths committed
320
           (entity-set-value! key "varchar" "maybe")
321 322 323 324 325 326 327 328 329 330 331 332 333
           (list
            (update-widget 'toggle-button (get-id (string-append id "-y")) 'checked 0)
            (update-widget 'toggle-button (get-id (string-append id "-n")) 'checked 0)))
          (else
           (list
            (update-widget 'toggle-button (get-id (string-append id "-m")) 'checked 1))))
         ))

      (mtoggle-button-no
       (string-append id "-n") ""
       (lambda (v)
         (cond
          (v
Dave Griffiths's avatar
Dave Griffiths committed
334
           (entity-set-value! key "varchar" "no")
335 336 337 338 339 340 341 342 343 344
           (list
            (update-widget 'toggle-button (get-id (string-append id "-y")) 'checked 0)
            (update-widget 'toggle-button (get-id (string-append id "-m")) 'checked 0)))
          (else
           (list
            (update-widget 'toggle-button (get-id (string-append id "-n")) 'checked 1))))
         ))))

    (text-view 0 text 30 (layout 'wrap-content 'wrap-parent '1 'centre 0)))))

Dave Griffiths's avatar
Dave Griffiths committed
345 346 347 348
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; review

(define (review-build-contents uid entity)
Dave Griffiths's avatar
Dave Griffiths committed
349
  (msg "review-build-contents")
Dave Griffiths's avatar
Dave Griffiths committed
350
  (append
351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376
   (foldl
    (lambda (ktv r)
      (append
       r (cond
          ((or (equal? (ktv-key ktv) "unique_id")
               (equal? (ktv-key ktv) "deleted")) '())
          ((equal? (ktv-type ktv) "varchar")
           (list (medit-text-value (string-append uid (ktv-key ktv))
                                   (ktv-key ktv)
                                   (ktv-value ktv) "normal"
                                   (lambda (v)
                                     (entity-set-value! (ktv-key ktv) (ktv-type ktv) v) '()))))
          ((equal? (ktv-type ktv) "int")
           (list (medit-text-value (string-append uid (ktv-key ktv))
                                   (ktv-key ktv)
                                   (number->string (ktv-value ktv)) "numeric"
                                   (lambda (v)
                                     (entity-set-value! (ktv-key ktv) (ktv-type ktv) v) '()))))
          ((equal? (ktv-type ktv) "real")
           (list (medit-text-value (string-append uid (ktv-key ktv))
                                   (ktv-key ktv)
                                   (number->string (ktv-value ktv)) "numeric"
                                   (lambda (v)
                                     (entity-set-value! (ktv-key ktv) (ktv-type ktv) v) '()))))
          (else (mtext "" (string-append (ktv-type ktv) " not handled")) '()))))
    '()
Dave Griffiths's avatar
Dave Griffiths committed
377 378
    entity)
   (list
Dave Griffiths's avatar
Dave Griffiths committed
379 380
    (horiz
     (mbutton "review-item-cancel" "Cancel" (lambda () (list (finish-activity 0))))
381 382 383 384
     (mbutton (string-append uid "-save") "Save"
              (lambda ()
                (entity-update-values!)
                (list (finish-activity 0))))))))
Dave Griffiths's avatar
Dave Griffiths committed
385 386 387 388 389 390 391 392 393 394 395

(define (review-item-build)
  (let ((uid (entity-get-value "unique_id")))
    (msg "review-item-build" uid)
    (list
     (update-widget
      'linear-layout
      (get-id "review-item-container")
      'contents
      (review-build-contents
       uid (get-current 'entity-values '()))))))
Dave Griffiths's avatar
Dave Griffiths committed
396 397 398 399 400 401 402 403 404 405 406

(define (review-update-list)
  (list
   (update-widget
    'linear-layout (get-id "review-list") 'contents
    (map
     (lambda (dirty-entity)
       ;; consists of ((type,uid,dirty,version) (ktvlist))
       (let* ((data (car dirty-entity))
              (entity (cadr dirty-entity))
              (time (ktv-get entity "time"))
Dave Griffiths's avatar
Dave Griffiths committed
407
              (type (list-ref data 0))
Dave Griffiths's avatar
Dave Griffiths committed
408
              (uid (list-ref data 1)))
Dave Griffiths's avatar
Dave Griffiths committed
409 410 411 412 413 414
         (mbutton
          (string-append "review-" uid)
          (string-append type (if time (string-append "-" time) ""))
          (lambda ()
            (entity-init! db "stream" type (get-entity-by-unique db "stream" uid))
            (list (start-activity "review-item" 0 ""))))))
Dave Griffiths's avatar
Dave Griffiths committed
415 416
     (dirty-entities-for-review db "stream")))))

417 418
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
Dave Griffiths's avatar
Dave Griffiths committed
419

420 421 422 423
(define (debug! txt)
  (set-current! 'debug-text (string-append txt "\n" (get-current 'debug-text ""))))

(define (update-debug)
424 425 426
  (update-widget 'debug-text-view (get-id "sync-debug") 'text
                 (get-current 'debug-text "")))

427
(define (debug-timer-cb)
Dave Griffiths's avatar
Dave Griffiths committed
428 429 430 431 432 433 434 435 436 437 438 439 440
  (append
   (cond
    ((get-current 'sync-on #f)
     (set-current! 'upload 0)
     (set-current! 'download 0)
     (connect-to-net
      (lambda ()
        (append
         (list (toast "sync-cb"))
         (upload-dirty db)
         (suck-new db "sync")))))
    (else '()))
   (list
441
    (delayed "debug-timer" (+ 10000 (random 5000)) debug-timer-cb)
Dave Griffiths's avatar
Dave Griffiths committed
442
    (update-debug))))
443

444

445 446
(define pf-length 20) ;; minutes...

447 448 449 450 451 452 453
(define (timer-cb)
  (set-current!
   'timer-seconds
   (- (get-current 'timer-seconds 59) 1))
  (append
   (cond
    ((< (get-current 'timer-seconds 59) 0)
454
     (set-current! 'timer-minutes (- (get-current 'timer-minutes pf-length) 1))
455
     (set-current! 'timer-seconds 59)
456 457 458 459 460 461 462 463 464 465 466 467 468 469
     (cond ((< (get-current 'timer-minutes pf-length) 1)
            (list
             (alert-dialog
              "pup-focal-end"
              "Pup focal time is up, have you finished?"
              (lambda (v)
                (cond
                 ((eqv? v 1)
                  (list (finish-activity 1)))
                 (else
                  (set-current! 'timer-minutes 1)
                  (list)))))))
           (else
            (list (replace-fragment (get-id "pf-top") "pf-scan1")))))
470 471 472 473 474
    (else '()))
   (list
    (delayed "timer" 1000 timer-cb)
    (update-widget
     'text-view (get-id "pf-timer-time-minutes") 'text
475
     (string-append (number->string (get-current 'timer-minutes pf-length))))
476 477 478 479 480
    (update-widget
     'text-view (get-id "pf-timer-time") 'text
     (string-append (number->string (get-current 'timer-seconds 59))))
    )))

Dave Griffiths's avatar
Dave Griffiths committed
481
(define (next-button id dialog-msg next-frag fn)
482 483 484 485 486 487 488 489 490 491 492 493 494 495 496
  (mbutton (string-append id "-nextb") "Next"
           (lambda ()
             (list
              (alert-dialog
               (string-append id "-d")
               dialog-msg
               (lambda (v)
                 (cond
                  ((eqv? v 1)
                   (msg "recording from next button")
                   (entity-update-values!)
                   (append
                    (fn) (list (replace-fragment
                                (get-id "gc-top") next-frag))))
                  (else '()))))))))
Dave Griffiths's avatar
Dave Griffiths committed
497

498 499 500 501
(define (force-pause)
  (list
   (delayed "timer" 1000 (lambda () '()))
   (update-widget 'toggle-button (get-id "pf-pause") 'checked 1)))
Dave Griffiths's avatar
Dave Griffiths committed
502

503 504
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; fragments
Dave Griffiths's avatar
Dave Griffiths committed
505 506 507

(define-fragment-list

508 509 510
  (fragment
   "pf-timer"
   (linear-layout
511
    (make-id "") 'vertical fillwrap trans-col
512
    (list
513
     (mtitle "pf-details" "Pack: xxx Pup: xxx")))
514 515 516
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
517 518 519 520 521 522
     (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"))
                     )))
523 524 525 526 527 528 529
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


  (fragment
530
   "events"
531
   (linear-layout
532
    0 'vertical fillwrap trans-col
533
    (list
534
     (linear-layout
Dave Griffiths's avatar
Dave Griffiths committed
535
      (make-id "ev-pf") 'vertical fill pf-col
536
      (list
537 538
       (mtitle "ev-pf-text" "Pup Focal Events")
       (horiz
Dave Griffiths's avatar
Dave Griffiths committed
539 540 541 542
        (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")))))))
543
     (linear-layout
544
      (make-id "ev-pf") 'vertical fill gp-col
545
      (list
546 547
       (mtitle "text" "Group Events")
       (horiz
Dave Griffiths's avatar
Dave Griffiths committed
548 549
        (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"))))
550 551
        (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")))))))))
552 553 554
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
555
     (if (equal? (get-current 'observation "none") obs-pf)
556 557
         (list
          (update-widget 'text-view (get-id "ev-pf-text") 'show 0)
Dave Griffiths's avatar
Dave Griffiths committed
558 559 560 561
          (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))))
562 563 564 565
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))
566

567 568 569
  (fragment
   "pf-scan1"
   (linear-layout
570
    (make-id "") 'vertical fillwrap pf-col
571
    (list
Dave Griffiths's avatar
Dave Griffiths committed
572
     (build-grid-selector "pf-scan-nearest" "single" "<b>Nearest Neighbour Scan</b>: Closest Mongoose")
573
     (build-grid-selector "pf-scan-close" "toggle" "Mongooses within 2m")
574 575
     (mbutton "pf-scan-done" "Done"
              (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
576
                (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
Dave Griffiths's avatar
Dave Griffiths committed
577
                (entity-record-values!)
578
                (list (replace-fragment (get-id "pf-top") "pf-timer"))))))
579 580 581 582

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
583
     (entity-init! db "stream" "pup-focal-nearest" '())
Dave Griffiths's avatar
Dave Griffiths committed
584
     (entity-set-value! "scan-time" "varchar" (date-time->string (date-time)))
585
     (list
586 587
      (play-sound "ping")
      (vibrate 300)
588
      (populate-grid-selector
589
       "pf-scan-nearest" "single"
590
       (db-mongooses-by-pack-adults) #t
591
       (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
592
         (entity-set-value! "id-nearest" "varchar" (ktv-get individual "unique_id"))
593 594
         (list)))
      (populate-grid-selector
595
       "pf-scan-close" "toggle"
596
       (db-mongooses-by-pack-adults) #t
597
       (lambda (individuals)
Dave Griffiths's avatar
Dave Griffiths committed
598
         (entity-set-value! "id-list-close" "varchar" (assemble-array individuals))
599 600
         (list)))
      ))
601 602 603 604 605 606
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


607 608 609
  (fragment
   "ev-pupfeed"
   (linear-layout
610
    (make-id "") 'vertical fillwrap pf-col
611
    (list
612
     (mtitle "title" "Event: Pup is fed")
613
     (build-grid-selector "pf-pupfeed-who" "single" "Who fed the pup?")
Dave Griffiths's avatar
Dave Griffiths committed
614
     (spacer 20)
615
     (horiz
Dave Griffiths's avatar
Dave Griffiths committed
616
      (mtext "text" "Food size")
617
      (spinner (make-id "pf-pupfeed-size") list-sizes fillwrap
618
               (lambda (v)
619
                 (entity-set-value! "size" "varchar" (list-ref list-sizes v)) '())))
Dave Griffiths's avatar
Dave Griffiths committed
620 621
     (spacer 20)
     (horiz
622 623
      (mbutton "pf-pupfeed-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
624
                 (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
Dave Griffiths's avatar
Dave Griffiths committed
625
                 (entity-record-values!)
626 627 628
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-pupfeed-cancel" "Cancel"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
629
                 (list (replace-fragment (get-id "event-holder") "events")))))))
630 631 632 633

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
634
     (entity-init!  db "stream" "pup-focal-pupfeed" '())
635 636 637
     (list
      (populate-grid-selector
       "pf-pupfeed-who" "single"
638
       (db-mongooses-by-pack-adults) #t
639
       (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
640
         (entity-set-value! "id-who" "varchar" (ktv-get individual "unique_id"))
641 642 643 644 645 646 647
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

Dave Griffiths's avatar
Dave Griffiths committed
648 649 650
  (fragment
   "ev-pupfind"
   (linear-layout
651
    (make-id "") 'vertical fillwrap pf-col
Dave Griffiths's avatar
Dave Griffiths committed
652
    (list
653
     (mtitle "title" "Event: Pup found food")
Dave Griffiths's avatar
Dave Griffiths committed
654 655 656
     (horiz
      (mtext "text" "Food size")
      (spinner (make-id "pf-pupfind-size") (list "Small" "Medium" "Large") fillwrap
Dave Griffiths's avatar
Dave Griffiths committed
657
               (lambda (v) (entity-set-value! "size" "varchar" v) '())))
Dave Griffiths's avatar
Dave Griffiths committed
658
     (spacer 20)
Dave Griffiths's avatar
Dave Griffiths committed
659
     (horiz
660 661
      (mbutton "pf-pupfind-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
662
                 (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
Dave Griffiths's avatar
Dave Griffiths committed
663
                 (entity-record-values!)
664 665 666
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-pupfind-cancel" "Cancel"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
667
                 (list (replace-fragment (get-id "event-holder") "events")))))))
Dave Griffiths's avatar
Dave Griffiths committed
668 669 670 671

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
672
     (entity-init! db "stream" "pup-focal-pupfind" '())
Dave Griffiths's avatar
Dave Griffiths committed
673 674 675 676 677 678 679 680 681 682 683
     (list
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


  (fragment
   "ev-pupcare"
   (linear-layout
684
    (make-id "") 'vertical fillwrap pf-col
Dave Griffiths's avatar
Dave Griffiths committed
685
    (list
686
     (mtitle "title" "Event: Pup is cared for")
Dave Griffiths's avatar
Dave Griffiths committed
687
     (build-grid-selector "pf-pupcare-who" "single" "Who cared for the pup?")
Dave Griffiths's avatar
Dave Griffiths committed
688
     (spacer 20)
Dave Griffiths's avatar
Dave Griffiths committed
689
     (horiz
Dave Griffiths's avatar
Dave Griffiths committed
690
      (mtext "text" "Type of care")
691 692
      (spinner (make-id "pf-pupcare-type") (list "Carry" "Lead" "Sniff" "Play" "Ano-genital sniff") fillwrap
               (lambda (v)
Dave Griffiths's avatar
Dave Griffiths committed
693
                 (entity-set-value! "type" "varchar" v) '())))
Dave Griffiths's avatar
Dave Griffiths committed
694 695
     (spacer 20)
     (horiz
696 697
      (mbutton "pf-pupcare-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
698
                 (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
Dave Griffiths's avatar
Dave Griffiths committed
699
                 (entity-record-values!)
700 701 702
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-pupcare-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)
Dave Griffiths's avatar
Dave Griffiths committed
708
     (entity-init! db "stream" "pup-focal-pupcare" '())
Dave Griffiths's avatar
Dave Griffiths committed
709 710 711
     (list
      (populate-grid-selector
       "pf-pupcare-who" "single"
712
       (db-mongooses-by-pack-adults) #t
Dave Griffiths's avatar
Dave Griffiths committed
713
       (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
714
         (entity-set-value! "id-who" "varchar" (ktv-get individual "unique_id"))
Dave Griffiths's avatar
Dave Griffiths committed
715 716 717 718 719 720 721 722 723 724
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "ev-pupaggr"
   (linear-layout
725
    (make-id "") 'vertical fillwrap pf-col
Dave Griffiths's avatar
Dave Griffiths committed
726
    (list
727
     (mtitle "title" "Event: Pup aggression")
Dave Griffiths's avatar
Dave Griffiths committed
728 729 730
     (build-grid-selector "pf-pupaggr-partner" "single" "Aggressive mongoose")

     (linear-layout
731
      (make-id "") 'horizontal (layout 'fill-parent 100 '1 'left 0) trans-col
Dave Griffiths's avatar
Dave Griffiths committed
732 733 734
      (list
       (vert
        (mtext "" "Fighting over")
735 736
        (spinner (make-id "pf-pupaggr-over") (list "Food" "Escort" "Nothing" "Other") fillwrap
                 (lambda (v)
Dave Griffiths's avatar
Dave Griffiths committed
737
                   (entity-set-value! "over" "varchar" v) '())))
Dave Griffiths's avatar
Dave Griffiths committed
738 739
       (vert
        (mtext "" "Level")
740 741
        (spinner (make-id "pf-pupaggr-level") (list "Block" "Snap" "Chase" "Push" "Fight") fillwrap
                 (lambda (v)
Dave Griffiths's avatar
Dave Griffiths committed
742
                   (entity-set-value! "level" "varchar" v) '())))
743 744 745 746 747

       (tri-state "pf-pupaggr-in" "Initiate?" "initiate")

       ;(mtoggle-button "pf-pupaggr-in" "Initiate?"
       ;                (lambda (v)
Dave Griffiths's avatar
Dave Griffiths committed
748
       ;                  (entity-set-value! "initiate" "varchar" (if v "yes" "no")) '()))
749 750 751 752


       (tri-state "pf-pupaggr-win" "Win?" "win")))

Dave Griffiths's avatar
Dave Griffiths committed
753
     (spacer 20)
754 755 756
     (horiz
      (mbutton "pf-pupaggr-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
757
                 (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
Dave Griffiths's avatar
Dave Griffiths committed
758
                 (entity-record-values!)
759 760 761 762 763
                 (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
764 765 766 767

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
768
     (entity-init! db "stream" "pup-focal-pupaggr" '())
Dave Griffiths's avatar
Dave Griffiths committed
769 770 771
     (list
      (populate-grid-selector
       "pf-pupaggr-partner" "single"
772
       (db-mongooses-by-pack) #t
Dave Griffiths's avatar
Dave Griffiths committed
773
       (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
774
         (entity-set-value! "id-with" "varchar" (ktv-get individual "unique_id"))
Dave Griffiths's avatar
Dave Griffiths committed
775 776 777 778 779 780 781
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

782 783 784 785 786 787 788
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (fragment
   "ev-grpint"
   (linear-layout
    (make-id "") 'vertical fillwrap gp-col
    (list
789 790 791 792 793
     (build-grid-selector "gp-int-leader" "single" "<b>Inter-group interaction</b> Leader mongoose")
     (horiz
      (linear-layout
       (make-id "") 'vertical (layout 400 'fill-parent '1 'left 0) trans-col
       (list
794
        (mtext "text" "Outcome")
795
        (spinner (make-id "gp-int-out") (list "Retreat" "Advance" "Fight retreat" "Fight win") fillwrap
796
                 (lambda (v)
Dave Griffiths's avatar
Dave Griffiths committed
797
                   (entity-set-value! "outcome" "varchar" v) '()))
798
        (mtext "text" "Duration")
799
        (edit-text (make-id "gp-int-dur") "" 30 "numeric" fillwrap
Dave Griffiths's avatar
Dave Griffiths committed
800
                   (lambda (v) (entity-set-value! "duration" "int" (string->number v)) '()))))
801 802 803 804
      (build-grid-selector "gp-int-pack" "single" "Other pack"))
     (linear-layout
      (make-id "") 'horizontal (layout 'fill-parent 80 '1 'left 0) trans-col
      (list
805 806
       (mbutton "pf-grpint-done" "Done"
                (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
807
                  (msg "entity-record-values about to be called?")
Dave Griffiths's avatar
Dave Griffiths committed
808
                  (entity-record-values!)
809 810 811
                  (list (replace-fragment (get-id "event-holder") "events"))))
       (mbutton "pf-grpint-cancel" "Cancel"
                (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
812
                  (list (replace-fragment (get-id "event-holder") "events"))))))))
813

814

815 816 817
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
818
     (entity-init! db "stream" "group-interaction" '())
819 820 821 822 823
     (append
      (force-pause)
      (list
       (populate-grid-selector
        "gp-int-pack" "single"
824
        (db-all-sort-normal db "sync" "pack") #f
825
        (lambda (pack)
Dave Griffiths's avatar
Dave Griffiths committed
826
          (entity-set-value! "id-other-pack" "varchar" (ktv-get pack "unique_id"))
827 828 829
          (list)))
       (populate-grid-selector
        "gp-int-leader" "single"
830
        (db-mongooses-by-pack) #t
831
        (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
832
          (entity-set-value! "id-leader" "varchar" (ktv-get individual "unique_id"))
833 834
          (list)))
       )))
835 836 837 838 839 840 841 842 843 844 845 846 847
   (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")
848 849 850 851 852 853 854 855

     (linear-layout
      (make-id "") 'horizontal fillwrap trans-col
      (list
       (vert
        (mtext "text" "Cause")
        (spinner (make-id "gp-alarm-cause") (list "Predator" "Other mongoose pack" "Humans" "Other" "Unknown") fillwrap
                 (lambda (v)
Dave Griffiths's avatar
Dave Griffiths committed
856
                   (entity-set-value! "cause" "varchar" v) '())))
857 858 859

       (tri-state "gp-alarm-join" "Did the others join in?" "others-join")))

860 861 862
     (horiz
      (mbutton "pf-grpalarm-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
863
                 (entity-record-values!)
864 865 866 867
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-grpalarm-cancel" "Cancel"
               (lambda ()
                 (list (replace-fragment (get-id "event-holder") "events")))))))
868 869 870 871

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
872
     (entity-init! db "stream" "group-alarm" '())
873 874 875 876 877
     (append
      (force-pause)
      (list
       (populate-grid-selector
        "gp-alarm-caller" "single"
878
        (db-mongooses-by-pack) #t
879
        (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
880
          (entity-set-value! "id-caller" "varchar" (ktv-get individual "unique_id"))
881
          (list))))
882 883 884 885 886 887 888 889 890 891 892
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "ev-grpmov"
   (linear-layout
    (make-id "") 'vertical fillwrap gp-col
    (list
Dave Griffiths's avatar
Dave Griffiths committed
893
     (build-grid-selector "gp-mov-leader" "single" "<b>Group movement</b>: Leader")
894
     (linear-layout
895
      (make-id "") 'horizontal (layout 'fill-parent 'wrap-content '1 'left 0) trans-col
896
      (list
Dave Griffiths's avatar
Dave Griffiths committed
897
       (medit-text "gp-mov-w" "Pack width" "numeric"
Dave Griffiths's avatar
Dave Griffiths committed
898
                   (lambda (v) (entity-set-value! "pack-width" "int" (string->number v)) '()))
Dave Griffiths's avatar
Dave Griffiths committed
899
       (medit-text "gp-mov-l" "Pack depth" "numeric"
Dave Griffiths's avatar
Dave Griffiths committed
900
                   (lambda (v) (entity-set-value! "pack-depth" "int" (string->number v)) '()))
Dave Griffiths's avatar
Dave Griffiths committed
901
       (medit-text "gp-mov-c" "How many?" "numeric"
Dave Griffiths's avatar
Dave Griffiths committed
902
                   (lambda (v) (entity-set-value! "pack-count" "int" (string->number v)) '()))))
903
     (linear-layout
904
      (make-id "") 'horizontal (layout 'fill-parent 'wrap-content '1 'left 0) trans-col
905
      (list
906 907
       (vert
        (mtext "" "Direction")
908
        (spinner (make-id "gp-mov-dir") (list "To" "From") fillwrap
Dave Griffiths's avatar
Dave Griffiths committed
909
                 (lambda (v) (entity-set-value! "direction" "varchar" v)  '())))
910

Dave Griffiths's avatar
Dave Griffiths committed
911 912 913
       (vert
        (mtext "" "Where to")
        (spinner (make-id "gp-mov-to") (list "Latrine" "Water" "Food" "Nothing" "Den" "Unknown") fillwrap
Dave Griffiths's avatar
Dave Griffiths committed
914
                 (lambda (v) (entity-set-value! "destination" "varchar" v)  '())))))
Dave Griffiths's avatar
Dave Griffiths committed
915 916 917 918 919

     (spacer 20)
     (horiz
      (mbutton "pf-grpmov-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
920
                 (entity-record-values!)
Dave Griffiths's avatar
Dave Griffiths committed
921 922 923 92