starwisp.scm 65.3 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 43
(define pup-focal-export
  (list
   "pup-focal-nearest"
   "pup-focal-pupfeed"
   "pup-focal-pupfind"
   "pup-focal-pupcare"
   "pup-focal-pupaggr"))


44 45
;; colours

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

58 59 60


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

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

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

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

86 87 88 89 90 91 92 93 94 95 96 97 98
(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...")))
99
  (msg (db-all-sort-normal db "local" "app-settings")))
Dave Griffiths's avatar
Dave Griffiths committed
100

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

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

107
(define (mbutton2 id title fn)
Dave Griffiths's avatar
Dave Griffiths committed
108
  (button (make-id id) title 30 (layout 150 100 1 'centre 10) fn))
109

110
(define (mtoggle-button id title fn)
111
  (toggle-button (make-id id) title 30 (layout 'fill-parent 'wrap-content 1 'centre 0) "fancy" fn))
112

113 114 115 116 117 118 119 120 121
(define (mtoggle-button-yes id title fn)
  (toggle-button (make-id id) title 30 (layout 49 43 1 'centre 0) "yes" fn))

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

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

122
(define (mtoggle-button2 id title fn)
123
  (toggle-button (make-id id) title 30 (layout 150 100 1 'centre 0) "plain" fn))
124

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

128
(define (mtitle id text)
129
  (text-view (make-id id) text 50 fillwrap))
130

131 132
(define (medit-text id text type fn)
  (vert
133
   (mtext (string-append id "-title") text)
134
   (edit-text (make-id id) "" 30 type fillwrap fn)))
135 136 137 138 139 140 141

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

142 143 144 145 146 147 148
(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))

149 150 151 152 153 154 155 156 157 158
(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))

159 160
;;;;

161
(define (build-grid-selector name type title)
162 163 164 165 166 167 168 169 170 171
  (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
172
      (image-view (make-id "im") "arrow_left" (layout 200 'fill-parent 1 'left 0))
173 174 175 176 177 178 179 180
      (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
181
          (button-grid (make-id name) type 3 30 (layout 100 60 1 'left 40)
182
                       (list) (lambda (v) '()))))))
183
      (image-view (make-id "im") "arrow_right" (layout 200 'fill-parent 1 'right 0)))))))
184

185
;; assumes grid selectors on mongeese only
186 187 188
(define (fast-get-name item)
  (list-ref (list-ref item 1) 2))

189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206
(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)
207 208
  (prof-start "popgrid")
  (prof-start "popgrid setup")
209
  (let ((id->items (build-button-items name items unknown))
210
        (selected-set '()))
211 212
    (prof-end "popgrid setup")
    (let ((r (update-widget
213 214
     'button-grid (get-id name) 'grid-buttons
     (list
215
      type 3 30 (layout 100 60 1 'left 0)
216 217
      (map
       (lambda (ii)
218
         (list (car ii) (caddr ii)))
219
       id->items)
220 221
      (lambda (v state)
        (cond
222 223
         ((equal? type "toggle")
          ;; update list of selected items
224 225 226 227 228 229 230 231 232
          (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
233
          ;;(msg (findv v id->items))
234
          (fn (cadr (findv v id->items))))))))))
235 236 237 238
      (prof-end "popgrid")
      r)))

(define (db-mongooses-by-pack)
239
  (db-all-where
240 241
   db "sync" "mongoose"
   (ktv "pack-id" "varchar" (ktv-get (get-current 'pack '()) "unique_id"))))
242

243 244 245 246 247 248
(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"))))


249
(define (db-mongooses-by-pack-male)
250
  (db-all-where2or
251 252
   db "sync" "mongoose"
   (ktv "pack-id" "varchar" (ktv-get (get-current 'pack '()) "unique_id"))
253
   (ktv "gender" "varchar" "Male") "Unknown"))
254 255

(define (db-mongooses-by-pack-female)
256
  (db-all-where2or
257 258
   db "sync" "mongoose"
   (ktv "pack-id" "varchar" (ktv-get (get-current 'pack '()) "unique_id"))
259
   (ktv "gender" "varchar" "Female") "Unknown"))
260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275


;; (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
276
  (db-all-newer
277 278 279 280
   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)))))

281 282 283 284 285 286
(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)))))

287 288 289 290 291 292 293 294 295 296 297 298 299 300


(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
301
           (entity-set-value! key "varchar" "yes")
302 303 304 305 306 307 308 309 310 311 312 313
           (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
314
           (entity-set-value! key "varchar" "maybe")
315 316 317 318 319 320 321 322 323 324 325 326 327
           (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
328
           (entity-set-value! key "varchar" "no")
329 330 331 332 333 334 335 336 337 338 339
           (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)))))


340 341
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
Dave Griffiths's avatar
Dave Griffiths committed
342

343 344 345 346
(define (debug! txt)
  (set-current! 'debug-text (string-append txt "\n" (get-current 'debug-text ""))))

(define (update-debug)
347 348 349
  (update-widget 'debug-text-view (get-id "sync-debug") 'text
                 (get-current 'debug-text "")))

350
(define (debug-timer-cb)
Dave Griffiths's avatar
Dave Griffiths committed
351 352 353 354 355 356 357 358 359 360 361 362 363
  (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
364
    (delayed "debug-timer" (+ 10000 (random 5000)) debug-timer-cb)
Dave Griffiths's avatar
Dave Griffiths committed
365
    (update-debug))))
366

367

368 369
(define pf-length 20) ;; minutes...

370 371 372 373 374 375 376
(define (timer-cb)
  (set-current!
   'timer-seconds
   (- (get-current 'timer-seconds 59) 1))
  (append
   (cond
    ((< (get-current 'timer-seconds 59) 0)
377
     (set-current! 'timer-minutes (- (get-current 'timer-minutes pf-length) 1))
378
     (set-current! 'timer-seconds 59)
379 380 381 382 383 384 385 386 387 388 389 390 391 392
     (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")))))
393 394 395 396 397
    (else '()))
   (list
    (delayed "timer" 1000 timer-cb)
    (update-widget
     'text-view (get-id "pf-timer-time-minutes") 'text
398
     (string-append (number->string (get-current 'timer-minutes pf-length))))
399 400 401 402 403
    (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
404 405 406 407 408 409 410 411 412 413 414 415 416 417 418
(define (next-button id dialog-msg next-frag fn)
     (mbutton (string-append id "-nextb") "Next"
              (lambda ()
                (list
                 (alert-dialog
                  (string-append id "-d")
                  dialog-msg
                  (lambda (v)
                    (cond
                     ((eqv? v 1)
                      (append
                       (fn) (list (replace-fragment
                                   (get-id "gc-top") next-frag))))
                     (else '()))))))))

419 420 421 422
(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
423

424 425
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; fragments
Dave Griffiths's avatar
Dave Griffiths committed
426 427 428

(define-fragment-list

429 430 431
  (fragment
   "pf-timer"
   (linear-layout
432
    (make-id "") 'vertical fillwrap trans-col
433
    (list
434
     (mtitle "pf-details" "Pack: xxx Pup: xxx")))
435 436 437
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
438 439 440 441 442 443
     (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"))
                     )))
444 445 446 447 448 449 450
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


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

488 489 490
  (fragment
   "pf-scan1"
   (linear-layout
491
    (make-id "") 'vertical fillwrap pf-col
492
    (list
Dave Griffiths's avatar
Dave Griffiths committed
493
     (build-grid-selector "pf-scan-nearest" "single" "<b>Nearest Neighbour Scan</b>: Closest Mongoose")
494
     (build-grid-selector "pf-scan-close" "toggle" "Mongooses within 2m")
495 496
     (mbutton "pf-scan-done" "Done"
              (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
497
                (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
Dave Griffiths's avatar
Dave Griffiths committed
498
                (entity-record-values!)
499
                (list (replace-fragment (get-id "pf-top") "pf-timer"))))))
500 501 502 503

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
504
     (entity-init! db "stream" "pup-focal-nearest" '())
Dave Griffiths's avatar
Dave Griffiths committed
505
     (entity-set-value! "scan-time" "varchar" (date-time->string (date-time)))
506
     (list
507 508
      (play-sound "ping")
      (vibrate 300)
509
      (populate-grid-selector
510
       "pf-scan-nearest" "single"
511
       (db-mongooses-by-pack-adults) #t
512
       (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
513
         (entity-set-value! "id-nearest" "varchar" (ktv-get individual "unique_id"))
514 515
         (list)))
      (populate-grid-selector
516
       "pf-scan-close" "toggle"
517
       (db-mongooses-by-pack-adults) #t
518
       (lambda (individuals)
Dave Griffiths's avatar
Dave Griffiths committed
519
         (entity-set-value! "id-list-close" "varchar" (assemble-array individuals))
520 521
         (list)))
      ))
522 523 524 525 526 527
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


528 529 530
  (fragment
   "ev-pupfeed"
   (linear-layout
531
    (make-id "") 'vertical fillwrap pf-col
532
    (list
533
     (mtitle "title" "Event: Pup is fed")
534
     (build-grid-selector "pf-pupfeed-who" "single" "Who fed the pup?")
Dave Griffiths's avatar
Dave Griffiths committed
535
     (spacer 20)
536
     (horiz
Dave Griffiths's avatar
Dave Griffiths committed
537
      (mtext "text" "Food size")
538 539
      (spinner (make-id "pf-pupfeed-size") (list "Small" "Medium" "Large") fillwrap
               (lambda (v)
Dave Griffiths's avatar
Dave Griffiths committed
540
                 (entity-set-value! "size" "varchar" v) '())))
Dave Griffiths's avatar
Dave Griffiths committed
541 542
     (spacer 20)
     (horiz
543 544
      (mbutton "pf-pupfeed-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
545
                 (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
Dave Griffiths's avatar
Dave Griffiths committed
546
                 (entity-record-values!)
547 548 549
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-pupfeed-cancel" "Cancel"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
550
                 (list (replace-fragment (get-id "event-holder") "events")))))))
551 552 553 554

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
555
     (entity-init!  db "stream" "pup-focal-pupfeed" '())
556 557 558
     (list
      (populate-grid-selector
       "pf-pupfeed-who" "single"
559
       (db-mongooses-by-pack-adults) #t
560
       (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
561
         (entity-set-value! "id-who" "varchar" (ktv-get individual "unique_id"))
562 563 564 565 566 567 568
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

Dave Griffiths's avatar
Dave Griffiths committed
569 570 571
  (fragment
   "ev-pupfind"
   (linear-layout
572
    (make-id "") 'vertical fillwrap pf-col
Dave Griffiths's avatar
Dave Griffiths committed
573
    (list
574
     (mtitle "title" "Event: Pup found food")
Dave Griffiths's avatar
Dave Griffiths committed
575 576 577
     (horiz
      (mtext "text" "Food size")
      (spinner (make-id "pf-pupfind-size") (list "Small" "Medium" "Large") fillwrap
Dave Griffiths's avatar
Dave Griffiths committed
578
               (lambda (v) (entity-set-value! "size" "varchar" v) '())))
Dave Griffiths's avatar
Dave Griffiths committed
579
     (spacer 20)
Dave Griffiths's avatar
Dave Griffiths committed
580
     (horiz
581 582
      (mbutton "pf-pupfind-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
583
                 (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
Dave Griffiths's avatar
Dave Griffiths committed
584
                 (entity-record-values!)
585 586 587
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-pupfind-cancel" "Cancel"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
588
                 (list (replace-fragment (get-id "event-holder") "events")))))))
Dave Griffiths's avatar
Dave Griffiths committed
589 590 591 592

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
593
     (entity-init! db "stream" "pup-focal-pupfind" '())
Dave Griffiths's avatar
Dave Griffiths committed
594 595 596 597 598 599 600 601 602 603 604
     (list
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


  (fragment
   "ev-pupcare"
   (linear-layout
605
    (make-id "") 'vertical fillwrap pf-col
Dave Griffiths's avatar
Dave Griffiths committed
606
    (list
607
     (mtitle "title" "Event: Pup is cared for")
Dave Griffiths's avatar
Dave Griffiths committed
608
     (build-grid-selector "pf-pupcare-who" "single" "Who cared for the pup?")
Dave Griffiths's avatar
Dave Griffiths committed
609
     (spacer 20)
Dave Griffiths's avatar
Dave Griffiths committed
610
     (horiz
Dave Griffiths's avatar
Dave Griffiths committed
611
      (mtext "text" "Type of care")
612 613
      (spinner (make-id "pf-pupcare-type") (list "Carry" "Lead" "Sniff" "Play" "Ano-genital sniff") fillwrap
               (lambda (v)
Dave Griffiths's avatar
Dave Griffiths committed
614
                 (entity-set-value! "type" "varchar" v) '())))
Dave Griffiths's avatar
Dave Griffiths committed
615 616
     (spacer 20)
     (horiz
617 618
      (mbutton "pf-pupcare-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
619
                 (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
Dave Griffiths's avatar
Dave Griffiths committed
620
                 (entity-record-values!)
621 622 623
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-pupcare-cancel" "Cancel"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
624
                 (list (replace-fragment (get-id "event-holder") "events")))))))
Dave Griffiths's avatar
Dave Griffiths committed
625 626 627 628

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

  (fragment
   "ev-pupaggr"
   (linear-layout
646
    (make-id "") 'vertical fillwrap pf-col
Dave Griffiths's avatar
Dave Griffiths committed
647
    (list
648
     (mtitle "title" "Event: Pup aggression")
Dave Griffiths's avatar
Dave Griffiths committed
649 650 651
     (build-grid-selector "pf-pupaggr-partner" "single" "Aggressive mongoose")

     (linear-layout
652
      (make-id "") 'horizontal (layout 'fill-parent 100 '1 'left 0) trans-col
Dave Griffiths's avatar
Dave Griffiths committed
653 654 655
      (list
       (vert
        (mtext "" "Fighting over")
656 657
        (spinner (make-id "pf-pupaggr-over") (list "Food" "Escort" "Nothing" "Other") fillwrap
                 (lambda (v)
Dave Griffiths's avatar
Dave Griffiths committed
658
                   (entity-set-value! "over" "varchar" v) '())))
Dave Griffiths's avatar
Dave Griffiths committed
659 660
       (vert
        (mtext "" "Level")
661 662
        (spinner (make-id "pf-pupaggr-level") (list "Block" "Snap" "Chase" "Push" "Fight") fillwrap
                 (lambda (v)
Dave Griffiths's avatar
Dave Griffiths committed
663
                   (entity-set-value! "level" "varchar" v) '())))
664 665 666 667 668

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

       ;(mtoggle-button "pf-pupaggr-in" "Initiate?"
       ;                (lambda (v)
Dave Griffiths's avatar
Dave Griffiths committed
669
       ;                  (entity-set-value! "initiate" "varchar" (if v "yes" "no")) '()))
670 671 672 673


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

Dave Griffiths's avatar
Dave Griffiths committed
674
     (spacer 20)
675 676 677
     (horiz
      (mbutton "pf-pupaggr-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
678
                 (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
Dave Griffiths's avatar
Dave Griffiths committed
679
                 (entity-record-values!)
680 681 682 683 684
                 (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
685 686 687 688

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
689
     (entity-init! db "stream" "pup-focal-pupaggr" '())
Dave Griffiths's avatar
Dave Griffiths committed
690 691 692
     (list
      (populate-grid-selector
       "pf-pupaggr-partner" "single"
693
       (db-mongooses-by-pack) #t
Dave Griffiths's avatar
Dave Griffiths committed
694
       (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
695
         (entity-set-value! "id-with" "varchar" (ktv-get individual "unique_id"))
Dave Griffiths's avatar
Dave Griffiths committed
696 697 698 699 700 701 702
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

703 704 705 706 707 708 709
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (fragment
   "ev-grpint"
   (linear-layout
    (make-id "") 'vertical fillwrap gp-col
    (list
710 711 712 713 714
     (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
715
        (mtext "text" "Outcome")
716
        (spinner (make-id "gp-int-out") (list "Retreat" "Advance" "Fight retreat" "Fight win") fillwrap
717
                 (lambda (v)
Dave Griffiths's avatar
Dave Griffiths committed
718
                   (entity-set-value! "outcome" "varchar" v) '()))
719
        (mtext "text" "Duration")
720
        (edit-text (make-id "gp-int-dur") "" 30 "numeric" fillwrap
Dave Griffiths's avatar
Dave Griffiths committed
721
                   (lambda (v) (entity-set-value! "duration" "int" (string->number v)) '()))))
722 723 724 725
      (build-grid-selector "gp-int-pack" "single" "Other pack"))
     (linear-layout
      (make-id "") 'horizontal (layout 'fill-parent 80 '1 'left 0) trans-col
      (list
726 727
       (mbutton "pf-grpint-done" "Done"
                (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
728
                  (entity-record-values!)
729 730 731
                  (list (replace-fragment (get-id "event-holder") "events"))))
       (mbutton "pf-grpint-cancel" "Cancel"
                (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
732
                  (list (replace-fragment (get-id "event-holder") "events"))))))))
733

734

735 736 737
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
738
     (entity-init! db "stream" "group-interaction" '())
739 740 741 742 743
     (append
      (force-pause)
      (list
       (populate-grid-selector
        "gp-int-pack" "single"
744
        (db-all-sort-normal db "sync" "pack") #f
745
        (lambda (pack)
Dave Griffiths's avatar
Dave Griffiths committed
746
          (entity-set-value! "id-other-pack" "varchar" (ktv-get pack "unique_id"))
747 748 749
          (list)))
       (populate-grid-selector
        "gp-int-leader" "single"
750
        (db-mongooses-by-pack) #t
751
        (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
752
          (entity-set-value! "id-leader" "varchar" (ktv-get individual "unique_id"))
753 754
          (list)))
       )))
755 756 757 758 759 760 761 762 763 764 765 766 767
   (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")
768 769 770 771 772 773 774 775

     (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
776
                   (entity-set-value! "cause" "varchar" v) '())))
777 778 779

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

780 781 782
     (horiz
      (mbutton "pf-grpalarm-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
783
                 (entity-record-values!)
784 785 786 787
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-grpalarm-cancel" "Cancel"
               (lambda ()
                 (list (replace-fragment (get-id "event-holder") "events")))))))
788 789 790 791

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
792
     (entity-init! db "stream" "group-alarm" '())
793 794 795 796 797
     (append
      (force-pause)
      (list
       (populate-grid-selector
        "gp-alarm-caller" "single"
798
        (db-mongooses-by-pack) #t
799
        (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
800
          (entity-set-value! "id-caller" "varchar" (ktv-get individual "unique_id"))
801
          (list))))
802 803 804 805 806 807 808 809 810 811 812
      ))
   (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
813
     (build-grid-selector "gp-mov-leader" "single" "<b>Group movement</b>: Leader")
814
     (linear-layout
815
      (make-id "") 'horizontal (layout 'fill-parent 90 '1 'left 0) trans-col
816
      (list
Dave Griffiths's avatar
Dave Griffiths committed
817
       (medit-text "gp-mov-w" "Pack width" "numeric"
Dave Griffiths's avatar
Dave Griffiths committed
818
                   (lambda (v) (entity-set-value! "pack-width" "int" (string->number v)) '()))
Dave Griffiths's avatar
Dave Griffiths committed
819
       (medit-text "gp-mov-l" "Pack depth" "numeric"
Dave Griffiths's avatar
Dave Griffiths committed
820
                   (lambda (v) (entity-set-value! "pack-depth" "int" (string->number v)) '()))
Dave Griffiths's avatar
Dave Griffiths committed
821
       (medit-text "gp-mov-c" "How many?" "numeric"
Dave Griffiths's avatar
Dave Griffiths committed
822
                   (lambda (v) (entity-set-value! "pack-count" "int" (string->number v)) '()))))
823
     (linear-layout
824
      (make-id "") 'horizontal (layout 'fill-parent 'wrap-content '1 'left 0) trans-col
825
      (list
826 827
       (vert
        (mtext "" "Direction")
828
        (spinner (make-id "gp-mov-dir") (list "To" "From") fillwrap
Dave Griffiths's avatar
Dave Griffiths committed
829
                 (lambda (v) (entity-set-value! "direction" "varchar" v)  '())))
830

Dave Griffiths's avatar
Dave Griffiths committed
831 832 833
       (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
834
                 (lambda (v) (entity-set-value! "destination" "varchar" v)  '())))))
Dave Griffiths's avatar
Dave Griffiths committed
835 836 837 838 839

     (spacer 20)
     (horiz
      (mbutton "pf-grpmov-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
840
                 (entity-record-values!)
Dave Griffiths's avatar
Dave Griffiths committed
841 842 843 844
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-grpalarm-cancel" "Cancel"
               (lambda ()
                 (list (replace-fragment (get-id "event-holder") "events")))))))
845 846 847 848

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
849
     (entity-init! db "stream" "group-move" '())
850 851 852 853 854
     (append
      (force-pause)
      (list
       (populate-grid-selector
        "gp-mov-leader" "single"
855
        (db-mongooses-by-pack) #t
856
        (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
857
          (entity-set-value! "id-leader" "varchar" (ktv-get individual "unique_id"))
858 859
          (list)))
       )))
860 861 862 863 864
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

865 866 867 868 869 870
  (fragment
   "note"
   (linear-layout
    (make-id "") 'vertical fillwrap gp-col
    (list
     (mtitle "title" "Make a note")
871
     (edit-text (make-id "note-text") "" 30 "text" fillwrap
872
                (lambda (v)
Dave Griffiths's avatar
Dave Griffiths committed
873
                  (entity-set-value! "text" "varchar" v)
874 875 876 877
                  '()))
     (horiz
      (mbutton "note-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
878
                 (entity-record-values!)
879 880 881 882 883 884 885
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "note-cancel" "Cancel"
               (lambda ()
                 (list (replace-fragment (get-id "event-holder") "events")))))))

   (lambda (fragment arg)
     (activity-layout fragment))
886
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
887
     (entity-init!  db "stream" "note" '())
888 889 890 891
     (append
      (force-pause)
      (list
       (update-widget 'edit-text (get-id "note-text") 'request-focus 1))))
892 893 894 895
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))
896 897 898 899


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

900

Dave Griffiths's avatar
Dave Griffiths committed
901
  ;;(replace-fragment (get-id "gc-top") (cadr frag))))))))
902

Dave Griffiths's avatar
Dave Griffiths committed
903
  (fragment
904
   "gc-start"
905
   (linear-layout
906
    (make-id "") 'vertical fill gc-col
907 908
    (list
     (mtitle "title" "Start")
Dave Griffiths's avatar
Dave Griffiths committed
909
     (mtoggle-button "gc-start-main-obs" "Main observer"
Dave Griffiths's avatar
Dave Griffiths committed
910
                     (lambda (v) (entity-set-value! "main-observer" "varchar" v) '()))
911
     (mtext "" "Code")
912
     (edit-text (make-id "gc-start-code") "" 30 "numeric" fillwrap
Dave Griffiths's avatar
Dave Griffiths committed
913
                (lambda (v) (entity-set-value! "group-comp-code" "varchar" v) '()))
Dave Griffiths's avatar
Dave Griffiths committed
914 915 916 917
     (build-grid-selector "gc-start-present" "toggle" "Who's present?")
     (next-button "gc-start-" "Go to weighing, have you finished here?" "gc-weights"
                  (lambda () '()))
     ))
918 919 920 921

   (lambda