starwisp.scm 81.8 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 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101
(define list-sizes (list (list 'small "Small")
                         (list 'medium "Medium")
                         (list 'large "Large")))

(define list-pupcare-type
  (list (list 'carry "Carry")
        (list 'lead "Lead")
        (list 'sniff "Sniff")
        (list 'play "Play")
        (list 'sniff "Ano-genital sniff")))

(define list-aggression-over
  (list (list 'food "Food")
        (list 'escort "Escort")
        (list 'nothing "Nothing")
        (list 'other "Other")))

(define list-aggression-level
  (list (list 'block "Block")
        (list 'snap "Snap")
        (list 'chase "Chase")
        (list 'push "Push")
        (list 'fight "Fight")))

(define list-interaction-outcome
  (list (list 'retreat "Retreat")
        (list 'advance "Advance")
        (list 'fight-retreat "Fight retreat")
        (list 'fight-win "Fight win")))

(define list-alarm-cause
  (list (list 'predator "Predator")
        (list 'other-pack "Other mongoose pack")
        (list 'humans "Humans")
        (list 'other "Other")
        (list 'unknown "Unknown")))

(define list-move-direction
  (list (list 'to "To")
        (list 'from "From")))

(define list-move-to
  (list (list 'latrine "Latrine")
        (list 'water "Water")
        (list 'food "Food")
        (list 'nothing "Nothing")
        (list 'den "Den")
        (list 'unknown "Unknown")))

(define list-strength
  (list (list 'weak "Weak")
        (list 'medium "Medium")
        (list 'strong "Strong")))

(define list-gender
  (list (list 'male "Male")
        (list 'female "Female")
        (list 'unknown "Unknown")))

102

103 104
;; colours

105 106 107 108 109 110 111 112 113 114 115 116
(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))

117 118 119


(define trans-col (list 0 0 0 0))
120 121 122 123 124 125 126 127 128 129 130 131 132 133

(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")
134
   (list "Pup assoc" "gc-pup-assoc")
135 136 137 138
   (list "Oestrus" "gc-oestrus")
   (list "Babysit" "gc-babysitting")
   (list "End" "gc-end")))

139
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Dave Griffiths's avatar
Dave Griffiths committed
140
;; persistent database
141

142
(define db "/sdcard/mongoose/local-mongoose.db")
143
(define main-db "/sdcard/mongoose/mongoose.db")
144

145 146 147 148 149 150 151 152 153 154 155 156 157
(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...")))
158
  (msg (db-all-sort-normal db "local" "app-settings")))
Dave Griffiths's avatar
Dave Griffiths committed
159

Dave Griffiths's avatar
Dave Griffiths committed
160
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
161
;; user interface abstraction
Dave Griffiths's avatar
Dave Griffiths committed
162

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

166
(define (mbutton2 id title fn)
167
  (button (make-id id) title 20 (layout 150 100 1 'centre 5) fn))
168

Dave Griffiths's avatar
Dave Griffiths committed
169 170 171
(define (mbutton-small id title fn)
  (button (make-id id) title 30 (layout 'wrap-content 'wrap-content -1 'right 5) fn))

172
(define (mtoggle-button id title fn)
173
  (toggle-button (make-id id) title 20 (layout 'fill-parent 'wrap-content 1 'centre 5) "fancy" fn))
174

175
(define (mtoggle-button-yes id title fn)
176
  (toggle-button (make-id id) title 20 (layout 49 43 1 'centre 0) "yes" fn))
177 178

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

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

184
(define (mtoggle-button2 id title fn)
185
  (toggle-button (make-id id) title 20 (layout 150 100 1 'centre 5) "plain" fn))
186

187 188 189
(define (mspinner id list fn)
  (spinner (make-id id) (map cadr list) fillwrap fn))

Dave Griffiths's avatar
Dave Griffiths committed
190
(define (mtext id text)
191
  (text-view (make-id id) text 20 fillwrap))
192

193
(define (mtitle id text)
194
  (text-view (make-id id) text 40 fillwrap))
195

196 197
(define (medit-text id text type fn)
  (vert
198
   (mtext (string-append id "-title") text)
199
   (edit-text (make-id id) "" 20 type fillwrap fn)))
200

Dave Griffiths's avatar
Dave Griffiths committed
201 202 203
(define (medit-text-value id text value type fn)
  (vert
   (mtext (string-append id "-title") text)
204
   (edit-text (make-id id) value 20 type fillwrap fn)))
Dave Griffiths's avatar
Dave Griffiths committed
205

206 207 208 209 210 211
(define (mclear-toggles id-list)
  (map
   (lambda (id)
     (update-widget 'toggle-button (get-id id) 'checked 0))
   id-list))

212 213 214 215 216 217 218
(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))

219 220 221 222 223 224 225 226 227 228
(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))

229 230
;;;;

231
(define (build-grid-selector name type title)
232 233 234 235 236 237 238 239 240 241
  (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
242
      (image-view (make-id "im") "arrow_left" (layout 200 'fill-parent 1 'left 0))
243 244
      (scroll-view
       (make-id "scroller")
245
       (layout 'wrap-content 'wrap-content 1 'left 5)
246 247 248
       (list
        (linear-layout
         (make-id name) 'horizontal
249
         (layout 'wrap-content 'wrap-content 1 'centre 5) trans-col
250
         (list
251
          (button-grid (make-id name) type 3 20 (layout 100 60 1 'left 5)
252
                       (list) (lambda (v) '()))))))
253
      (image-view (make-id "im") "arrow_right" (layout 200 'fill-parent 1 'right 0)))))))
254

255
;; assumes grid selectors on mongeese only
256
;; assumes order of ktv elements?
257 258 259
(define (fast-get-name item)
  (list-ref (list-ref item 1) 2))

260 261 262
(define (fast-get-id item)
  (list-ref (list-ref item 0) 2))

263 264 265 266
(define (build-button-items name items unknown)
  (append
   (map
    (lambda (item)
267 268
      (list (make-id (string-append name (fast-get-id item)))
            item (fast-get-name item)))
269 270 271 272 273 274 275 276 277
    items)
   (if unknown
       (list
        (list (make-id (string-append name "-unknown"))
              (list (ktv "name" "varchar" "Unknown")
                    (ktv "unique_id" "varchar" "Unknown"))
              "???"))
       '())))

278
(define (populate-grid-selector name type items unknown fn . args)
279
  (let ((id->items (build-button-items name items unknown))
280 281
        (selected-set (if (null? args)
                          '()
282 283 284 285 286 287
                          (foldl
                           (lambda (uid r)
                             (if (not (equal? uid "none"))
                                 (cons (get-id (string-append name uid)) r) r))
                           '()
                           (car args)))))
288
    (let ((r (update-widget
289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310
              'button-grid (get-id name) 'grid-buttons
              (list
               type 3 20 (layout 80 50 1 'left 2)
               (map
                (lambda (ii)
                  (list (car ii) (caddr ii)))
                id->items)
               (lambda (v state)
                 (cond
                  ((equal? type "toggle")
                   ;; update list of selected items
                   (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))
                   (fn (cadr (findv v id->items))))))))))
311 312
      r)))

313 314 315 316 317

(define (update-grid-selector-colours id item-id items)
  (map
   (lambda (item)
     (update-widget 'button (get-id (string-append id (ktv-get item item-id)))
318
                    'background-colour (list 255 255 0 155)))
319 320 321 322 323 324 325 326 327
   items))

(define (update-grid-selector-enabled id items)
  (map
   (lambda (item)
     (update-widget 'button (get-id (string-append id item))
                    'set-enabled 0))
   items))

328 329
(define (update-grid-selector-checked id items-id)
  (let ((items-str (entity-get-value items-id)))
330
    (msg "selector-checked for" id items-id items-str)
331 332 333 334 335 336
    (if items-str
        (map
         (lambda (item)
           (update-widget 'toggle-button (get-id (string-append id item)) 'checked 1))
         (string-split-simple items-str #\,))
        '())))
337

338 339 340 341 342 343
(define (get-grid-select-init-state key)
  (let ((v (entity-get-value key)))
    (if v
        (string-split-simple v #\,)
        '())))

344
(define (db-mongooses-by-pack)
345
  (db-all-where
346 347
   db "sync" "mongoose"
   (ktv "pack-id" "varchar" (ktv-get (get-current 'pack '()) "unique_id"))))
348

349 350 351 352 353 354
(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"))))


355
(define (db-mongooses-by-pack-male)
356
  (db-all-where2or
357 358
   db "sync" "mongoose"
   (ktv "pack-id" "varchar" (ktv-get (get-current 'pack '()) "unique_id"))
359
   (ktv "gender" "varchar" "Male") "Unknown"))
360 361

(define (db-mongooses-by-pack-female)
362
  (db-all-where2or
363 364
   db "sync" "mongoose"
   (ktv "pack-id" "varchar" (ktv-get (get-current 'pack '()) "unique_id"))
365
   (ktv "gender" "varchar" "Female") "Unknown"))
366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381


;; (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
382
  (db-all-newer
383 384 385 386
   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)))))

387 388 389 390 391 392
(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)))))

393 394 395 396 397 398 399 400 401 402 403 404 405 406


(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
407
           (entity-set-value! key "varchar" "yes")
408 409 410 411 412 413 414 415 416 417 418 419
           (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
420
           (entity-set-value! key "varchar" "maybe")
421 422 423 424 425 426 427 428 429 430 431 432 433
           (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
434
           (entity-set-value! key "varchar" "no")
435 436 437 438 439 440 441 442 443 444
           (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
445 446 447
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; review

448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503
(define (ktv-key-is-id? ktv)
  (equal? (substring (ktv-key ktv) 0 3) "id-"))

;; search for a comma in a list of ids
(define (ktv-value-is-list? ktv)
  (foldl
   (lambda (c r)
     (if (or r (eqv? c #\,)) #t r))
   #f
   (string->list (ktv-value ktv))))

(define (review-build-id ktv)
  (let* ((uid (ktv-value ktv))
         (entity-id (entity-id-from-unique db "sync" uid))
         (type (get-entity-type db "sync" entity-id))
         (name (ktv-get (get-entity-only db "sync" entity-id
                                         (list (list "name" "varchar")))
                        "name")))
    (msg (ktv-value ktv) entity-id type name)
    (list (medit-text-value
           (string-append uid (ktv-key ktv))
           (ktv-key ktv)
           name "normal"
           (lambda (v)
             (entity-set-value! (ktv-key ktv) (ktv-type ktv) v)
             '())))))

(define (convert-id name)
  (let ((new-entity (db-filter-only
                     db "sync" "*"
                     (list (list "name" "varchar" "=" name))
                     (list))))
    (msg "in convert-id")
    (msg new-entity)
    (if (null? new-entity)
        #f
        (ktv-get (car new-entity) "unique_id"))))

;; replace entity with names -> uids, or name of not found
(define (review-validate-contents uid entity)
  (msg "review-validate-contents")
  (foldl
   (lambda (ktv r)
     (cond
      ((string? r) r) ;; we have already found an error
      ((ktv-key-is-id? ktv)
       (let ((replacement (convert-id (ktv-value ktv))))
         (if replacement
             (cons (list (ktv-key ktv) (ktv-type ktv) replacement) r)
             ;; ditch the entity and return error
             (ktv-value ktv))))
      (else (cons ktv r))))
   '()
   entity))


Dave Griffiths's avatar
Dave Griffiths committed
504
(define (review-build-contents uid entity)
Dave Griffiths's avatar
Dave Griffiths committed
505
  (msg "review-build-contents")
Dave Griffiths's avatar
Dave Griffiths committed
506
  (append
507 508
   (foldl
    (lambda (ktv r)
509
      (msg ktv)
510 511
      (append
       r (cond
512 513
          ((or (equal? (ktv-key ktv) "parent")
               (equal? (ktv-key ktv) "unique_id")
514 515
               (equal? (ktv-key ktv) "deleted")) '())
          ((equal? (ktv-type ktv) "varchar")
516 517 518 519 520 521 522 523 524 525 526 527 528
           (msg "building review varchar")
           (if (ktv-key-is-id? ktv)
               ;;(if (ktv-value-is-list? ktv)
               (begin
                 (msg "we have an id...")
                 (review-build-id ktv))
               ;;     (review-build-list ktv))
               ;; normal 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) '())))))
529 530 531 532 533 534 535 536 537
          ((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)
538 539 540 541
                                   ;; get around previous bug, should remove
                                   (if (number? (ktv-value ktv))
                                       (number->string (ktv-value ktv))
                                       (ktv-value ktv)) "numeric"
542 543 544 545
                                   (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
546 547
    entity)
   (list
Dave Griffiths's avatar
Dave Griffiths committed
548 549
    (horiz
     (mbutton "review-item-cancel" "Cancel" (lambda () (list (finish-activity 0))))
550 551
     (mbutton (string-append uid "-save") "Save"
              (lambda ()
552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569
                (let ((new-entity (review-validate-contents uid (get-current 'entity-values '()))))
                  (msg "from review-validate-contents:" new-entity)
                  (cond
                   ((list? new-entity)
                    ;; replace with converted ids
                    (set-current! 'entity-values new-entity)
                    ;;(entity-update-values!)
                    (list (finish-activity 0)))
                   (else
                    (list
                     (alert-dialog
                      "mongoose-not-found"
                      (string-append "Mongoose " new-entity " not found!")
                      (lambda (v)
                        (cond
                         ((eqv? v 1) (list))
                         (else (list)))))))))))))))

Dave Griffiths's avatar
Dave Griffiths committed
570 571 572 573 574 575 576 577 578 579 580

(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
581 582 583 584 585 586 587 588 589 590 591

(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
592
              (type (list-ref data 0))
Dave Griffiths's avatar
Dave Griffiths committed
593
              (uid (list-ref data 1)))
Dave Griffiths's avatar
Dave Griffiths committed
594 595 596 597 598 599
         (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
600 601
     (dirty-entities-for-review db "stream")))))

602 603
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
Dave Griffiths's avatar
Dave Griffiths committed
604

605 606 607 608
(define (debug! txt)
  (set-current! 'debug-text (string-append txt "\n" (get-current 'debug-text ""))))

(define (update-debug)
609 610 611
  (update-widget 'debug-text-view (get-id "sync-debug") 'text
                 (get-current 'debug-text "")))

612
(define (debug-timer-cb)
Dave Griffiths's avatar
Dave Griffiths committed
613 614 615 616 617 618 619
  (append
   (cond
    ((get-current 'sync-on #f)
     (set-current! 'upload 0)
     (set-current! 'download 0)
     (connect-to-net
      (lambda ()
620
        (msg "connected, going in...")
Dave Griffiths's avatar
Dave Griffiths committed
621 622 623
        (append
         (list (toast "sync-cb"))
         (upload-dirty db)
624 625 626 627 628 629
         ;; important - don't receive until all are sent...
         (if (or (have-dirty? db "sync")
                 (have-dirty? db "stream")) '()
             (append
              (suck-new db "sync")
              (start-sync-files)))))))
Dave Griffiths's avatar
Dave Griffiths committed
630 631
    (else '()))
   (list
632
    (delayed "debug-timer" (+ 10000 (random 5000)) debug-timer-cb)
Dave Griffiths's avatar
Dave Griffiths committed
633
    (update-debug))))
634

635

636 637
(define pf-length 20) ;; minutes...

638 639 640 641 642 643 644
(define (timer-cb)
  (set-current!
   'timer-seconds
   (- (get-current 'timer-seconds 59) 1))
  (append
   (cond
    ((< (get-current 'timer-seconds 59) 0)
645
     (set-current! 'timer-minutes (- (get-current 'timer-minutes pf-length) 1))
646
     (set-current! 'timer-seconds 59)
647 648 649 650 651 652 653 654 655 656 657 658 659 660
     (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")))))
661 662 663 664 665
    (else '()))
   (list
    (delayed "timer" 1000 timer-cb)
    (update-widget
     'text-view (get-id "pf-timer-time-minutes") 'text
666
     (string-append (number->string (get-current 'timer-minutes pf-length))))
667 668 669 670 671
    (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
672
(define (next-button id dialog-msg last-frag next-frag fn)
673 674 675 676
  (vert
   (spacer 30)
   (horiz
    (mbutton (string-append id "-backb") "Back"
Dave Griffiths's avatar
Dave Griffiths committed
677 678 679
             (lambda ()
               (list (replace-fragment (get-id "gc-top") last-frag))))

680
    (mbutton (string-append id "-nextb") "Next"
Dave Griffiths's avatar
Dave Griffiths committed
681
             (lambda ()
682 683 684 685 686 687
               (msg "update from next button")
               (entity-update-values!)
               (append
                (fn)
                (list
                 (replace-fragment (get-id "gc-top") next-frag))))))))
Dave Griffiths's avatar
Dave Griffiths committed
688

689 690 691 692
(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
693

694

695
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
696

697 698 699 700 701 702 703 704
(define (update-selector-colours id entity-type where)
  (update-grid-selector-colours
   id "id-mongoose"
   (db-filter
    db "stream" entity-type
    (list
     (list "parent" "varchar" "=" (get-current 'group-composition-id 0))
     where))))
705

706 707
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; fragments
Dave Griffiths's avatar
Dave Griffiths committed
708 709 710

(define-fragment-list

711 712 713
  (fragment
   "pf-timer"
   (linear-layout
714
    (make-id "") 'vertical fillwrap trans-col
715
    (list
716
     (mtitle "pf-details" "Pack: xxx Pup: xxx")))
717 718 719
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
720 721 722 723 724 725
     (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"))
                     )))
726 727 728 729 730 731 732
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


  (fragment
733
   "events"
734
   (linear-layout
735
    0 'vertical fillwrap trans-col
736
    (list
737
     (linear-layout
Dave Griffiths's avatar
Dave Griffiths committed
738
      (make-id "ev-pf") 'vertical fill pf-col
739
      (list
740 741
       (mtitle "ev-pf-text" "Pup Focal Events")
       (horiz
Dave Griffiths's avatar
Dave Griffiths committed
742 743 744 745
        (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")))))))
746
     (linear-layout
747
      (make-id "ev-pf") 'vertical fill gp-col
748
      (list
749 750
       (mtitle "text" "Group Events")
       (horiz
Dave Griffiths's avatar
Dave Griffiths committed
751 752
        (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"))))
753 754
        (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")))))))))
755 756 757
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
758
     (if (equal? (get-current 'observation "none") obs-pf)
759 760
         (list
          (update-widget 'text-view (get-id "ev-pf-text") 'show 0)
Dave Griffiths's avatar
Dave Griffiths committed
761 762 763 764
          (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))))
765 766 767 768
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))
769

770 771 772
  (fragment
   "pf-scan1"
   (linear-layout
773
    (make-id "") 'vertical fillwrap pf-col
774
    (list
Dave Griffiths's avatar
Dave Griffiths committed
775
     (build-grid-selector "pf-scan-nearest" "single" "<b>Nearest Neighbour Scan</b>: Closest Mongoose")
776
     (build-grid-selector "pf-scan-close" "toggle" "Mongooses within 2m")
777 778
     (mbutton "pf-scan-done" "Done"
              (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
779
                (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
Dave Griffiths's avatar
Dave Griffiths committed
780
                (entity-record-values!)
781
                (list (replace-fragment (get-id "pf-top") "pf-timer"))))))
782 783 784 785

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
786
     (entity-init! db "stream" "pup-focal-nearest" '())
Dave Griffiths's avatar
Dave Griffiths committed
787
     (entity-set-value! "scan-time" "varchar" (date-time->string (date-time)))
788
     (list
789 790
      (play-sound "ping")
      (vibrate 300)
791
      (populate-grid-selector
792
       "pf-scan-nearest" "single"
793
       (db-mongooses-by-pack-adults) #t
794
       (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
795
         (entity-set-value! "id-nearest" "varchar" (ktv-get individual "unique_id"))
796 797
         (list)))
      (populate-grid-selector
798
       "pf-scan-close" "toggle"
799
       (db-mongooses-by-pack-adults) #t
800
       (lambda (individuals)
Dave Griffiths's avatar
Dave Griffiths committed
801
         (entity-set-value! "id-list-close" "varchar" (assemble-array individuals))
802 803
         (list)))
      ))
804 805 806 807 808 809
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


810 811 812
  (fragment
   "ev-pupfeed"
   (linear-layout
813
    (make-id "") 'vertical fillwrap pf-col
814
    (list
815
     (mtitle "title" "Event: Pup is fed")
816
     (build-grid-selector "pf-pupfeed-who" "single" "Who fed the pup?")
Dave Griffiths's avatar
Dave Griffiths committed
817
     (spacer 20)
818
     (horiz
Dave Griffiths's avatar
Dave Griffiths committed
819
      (mtext "text" "Food size")
820 821 822
      (mspinner "pf-pupfeed-size" list-sizes
                (lambda (v)
                  (entity-set-value! "size" "varchar" (spinner-choice list-sizes v)) '())))
Dave Griffiths's avatar
Dave Griffiths committed
823 824
     (spacer 20)
     (horiz
825 826
      (mbutton "pf-pupfeed-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
827
                 (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
Dave Griffiths's avatar
Dave Griffiths committed
828
                 (entity-record-values!)
829 830 831
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-pupfeed-cancel" "Cancel"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
832
                 (list (replace-fragment (get-id "event-holder") "events")))))))
833 834 835 836

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
837
     (entity-init!  db "stream" "pup-focal-pupfeed" '())
838 839 840
     (list
      (populate-grid-selector
       "pf-pupfeed-who" "single"
841
       (db-mongooses-by-pack-adults) #t
842
       (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
843
         (entity-set-value! "id-who" "varchar" (ktv-get individual "unique_id"))
844 845 846 847 848 849 850
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

Dave Griffiths's avatar
Dave Griffiths committed
851 852 853
  (fragment
   "ev-pupfind"
   (linear-layout
854
    (make-id "") 'vertical fillwrap pf-col
Dave Griffiths's avatar
Dave Griffiths committed
855
    (list
856
     (mtitle "title" "Event: Pup found food")
Dave Griffiths's avatar
Dave Griffiths committed
857 858
     (horiz
      (mtext "text" "Food size")
859 860
      (mspinner "pf-pupfind-size" list-sizes
                (lambda (v) (entity-set-value! "size" "varchar" (spinner-choice list-sizes v)) '())))
Dave Griffiths's avatar
Dave Griffiths committed
861
     (spacer 20)
Dave Griffiths's avatar
Dave Griffiths committed
862
     (horiz
863 864
      (mbutton "pf-pupfind-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
865
                 (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
Dave Griffiths's avatar
Dave Griffiths committed
866
                 (entity-record-values!)
867 868 869
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-pupfind-cancel" "Cancel"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
870
                 (list (replace-fragment (get-id "event-holder") "events")))))))
Dave Griffiths's avatar
Dave Griffiths committed
871 872 873 874

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
875
     (entity-init! db "stream" "pup-focal-pupfind" '())
Dave Griffiths's avatar
Dave Griffiths committed
876 877 878 879 880 881 882 883 884 885 886
     (list
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


  (fragment
   "ev-pupcare"
   (linear-layout
887
    (make-id "") 'vertical fillwrap pf-col
Dave Griffiths's avatar
Dave Griffiths committed
888
    (list
889
     (mtitle "title" "Event: Pup is cared for")
Dave Griffiths's avatar
Dave Griffiths committed
890
     (build-grid-selector "pf-pupcare-who" "single" "Who cared for the pup?")
Dave Griffiths's avatar
Dave Griffiths committed
891
     (spacer 20)
Dave Griffiths's avatar
Dave Griffiths committed
892
     (horiz
Dave Griffiths's avatar
Dave Griffiths committed
893
      (mtext "text" "Type of care")
894
      (mspinner "pf-pupcare-type" list-pupcare-type
895
               (lambda (v)
896
                 (entity-set-value! "type" "varchar" (spinner-choice list-pupcare-type v)) '())))
Dave Griffiths's avatar
Dave Griffiths committed
897 898
     (spacer 20)
     (horiz
899 900
      (mbutton "pf-pupcare-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
901
                 (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
Dave Griffiths's avatar
Dave Griffiths committed
902
                 (entity-record-values!)
903 904 905
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-pupcare-cancel" "Cancel"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
906
                 (list (replace-fragment (get-id "event-holder") "events")))))))
Dave Griffiths's avatar
Dave Griffiths committed
907 908 909 910

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
911
     (entity-init! db "stream" "pup-focal-pupcare" '())
Dave Griffiths's avatar
Dave Griffiths committed
912 913 914
     (list
      (populate-grid-selector
       "pf-pupcare-who" "single"
915
       (db-mongooses-by-pack-adults) #t
Dave Griffiths's avatar
Dave Griffiths committed
916
       (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
917
         (entity-set-value! "id-who" "varchar" (ktv-get individual "unique_id"))
Dave Griffiths's avatar
Dave Griffiths committed
918 919 920 921 922 923 924 925 926 927
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "ev-pupaggr"
   (linear-layout
928
    (make-id "") 'vertical fillwrap pf-col
Dave Griffiths's avatar
Dave Griffiths committed
929
    (list
930
     (mtitle "title" "Event: Pup aggression")
Dave Griffiths's avatar
Dave Griffiths committed
931 932 933
     (build-grid-selector "pf-pupaggr-partner" "single" "Aggressive mongoose")

     (linear-layout
934
      (make-id "") 'horizontal (layout 'fill-parent 100 '1 'left 0) trans-col
Dave Griffiths's avatar
Dave Griffiths committed
935 936 937
      (list
       (vert
        (mtext "" "Fighting over")
938 939 940
        (mspinner "pf-pupaggr-over" list-aggression-over
                  (lambda (v)
                    (entity-set-value! "over" "varchar" (spinner-choice list-aggression-over v)) '())))
Dave Griffiths's avatar
Dave Griffiths committed
941 942
       (vert
        (mtext "" "Level")
943 944 945
        (mspinner "pf-pupaggr-level" list-aggression-level
                  (lambda (v)
                    (entity-set-value! "level" "varchar" (spinner-choice list-aggression-level v)) '())))
946 947 948 949 950

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

       ;(mtoggle-button "pf-pupaggr-in" "Initiate?"
       ;                (lambda (v)
Dave Griffiths's avatar
Dave Griffiths committed
951
       ;                  (entity-set-value! "initiate" "varchar" (if v "yes" "no")) '()))
952 953 954 955


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

Dave Griffiths's avatar
Dave Griffiths committed
956
     (spacer 20)
957 958 959
     (horiz
      (mbutton "pf-pupaggr-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
960
                 (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
Dave Griffiths's avatar
Dave Griffiths committed
961
                 (entity-record-values!)
962 963 964 965 966
                 (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
967 968 969 970

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
971
     (entity-init! db "stream" "pup-focal-pupaggr" '())
Dave Griffiths's avatar
Dave Griffiths committed
972 973 974
     (list
      (populate-grid-selector
       "pf-pupaggr-partner" "single"
975
       (db-mongooses-by-pack) #t
Dave Griffiths's avatar
Dave Griffiths committed
976
       (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
977
         (entity-set-value! "id-with" "varchar" (ktv-get individual "unique_id"))
Dave Griffiths's avatar
Dave Griffiths committed
978 979 980 981 982 983 984
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

985 986 987 988 989 990 991
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (fragment
   "ev-grpint"
   (linear-layout
    (make-id "") 'vertical fillwrap gp-col
    (list
992 993 994 995 996
     (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
997
        (mtext "text" "Outcome")
998 999 1000
        (mspinner "gp-int-out" list-interaction-outcome
                  (lambda (v)
                    (entity-set-value! "outcome" "varchar" (spinner-choice list-interaction-outcome v)) '()))
1001
        (mtext "text" "Duration")
1002
        (edit-text (make-id "gp-int-dur") "" 30 "numeric" fillwrap
Dave Griffiths's avatar
Dave Griffiths committed
1003
                   (lambda (v) (entity-set-value! "duration" "int" (string->number v)) '()))))
1004 1005 1006 1007
      (build-grid-selector "gp-int-pack" "single" "Other pack"))
     (linear-layout
      (make-id "") 'horizontal (layout 'fill-parent 80 '1 'left 0) trans-col
      (list
1008 1009
       (mbutton "pf-grpint-done" "Done"
                (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
1010
                  (msg "entity-record-values about to be called?")
Dave Griffiths's avatar