starwisp.scm 84.5 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
(define (ktv-key-is-id? ktv)
449 450 451 452
  (or
   (equal? (ktv-key ktv) "pack")
   (equal? (ktv-key ktv) "present")
   (equal? (substring (ktv-key ktv) 0 3) "id-")))
453 454 455 456 457 458 459 460 461

;; 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))))

462 463 464 465 466 467
(define (uid->name uid)
  (let* ((entity-id (entity-id-from-unique db "sync" uid)))
    (ktv-get (get-entity-only db "sync" entity-id
                              (list (list "name" "varchar")))
             "name")))

468
(define (review-build-id ktv)
469 470 471 472 473 474 475 476 477 478
  (list (medit-text-value
         (string-append (ktv-value ktv) (ktv-key ktv))
         (ktv-key ktv)
         (uid->name (ktv-value ktv)) "normal"
         (lambda (v)
           (entity-set-value! (ktv-key ktv) (ktv-type ktv) v)
           '()))))

(define (review-build-list ktv)
  (let ((ids (string-split-simple (ktv-value ktv) #\,)))
479 480
    (list (medit-text-value
           (ktv-key ktv)
481 482 483 484 485 486 487 488 489
           (ktv-key ktv)
           (foldl
            (lambda (id r)
              (if (equal? r "")
                  (uid->name id)
                  (string-append r ", " (uid->name id))))
            ""
            ids)
           "normal"
490 491 492 493
           (lambda (v)
             (entity-set-value! (ktv-key ktv) (ktv-type ktv) v)
             '())))))

494

495
(define (convert-id name)
496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518
  (let ((name (string-remove-whitespace name)))
    ;; search for unique id first
    (if (entity-exists? db "sync" name)
        name
        (let ((new-entity (db-filter-only
                           db "sync" "*"
                           (list (list "name" "varchar" "=" name))
                           (list))))
          (if (null? new-entity)
              #f
              (ktv-get (car new-entity) "unique_id"))))))

(define (convert-id-list str)
  (let ((names (string-split-simple str #\,)))
    (foldl
     (lambda (name r)
       (if (string? r)
           (let ((id (convert-id name)))
             (if id
                 (if (equal? r "") id (string-append r "," id))
                 #f))
           #f))
     "" names)))
519 520 521 522 523 524 525 526

;; replace entity with names -> uids, or name of not found
(define (review-validate-contents uid entity)
  (foldl
   (lambda (ktv r)
     (cond
      ((string? r) r) ;; we have already found an error
      ((ktv-key-is-id? ktv)
527 528 529 530
       (let ((replacement
              (if (ktv-value-is-list? ktv)
                  (convert-id-list (ktv-value ktv))
                  (convert-id (ktv-value ktv)))))
531 532 533 534 535 536 537 538 539
         (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
540 541
(define (review-build-contents uid entity)
  (append
542 543 544 545
   (foldl
    (lambda (ktv r)
      (append
       r (cond
546 547 548 549 550 551 552 553
          ((or
            (equal? (ktv-key ktv) "user")
            (equal? (ktv-key ktv) "lat")
            (equal? (ktv-key ktv) "lon")
            (equal? (ktv-key ktv) "time")
            (equal? (ktv-key ktv) "parent")
            (equal? (ktv-key ktv) "unique_id")
            (equal? (ktv-key ktv) "deleted")) '())
554
          ((equal? (ktv-type ktv) "varchar")
555
           (if (ktv-key-is-id? ktv)
556 557 558
               (if (ktv-value-is-list? ktv)
                   (review-build-list ktv)
                   (review-build-id ktv))
559 560 561 562 563 564
               ;; 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) '())))))
565 566 567 568 569 570 571 572 573
          ((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)
574 575 576 577
                                   ;; get around previous bug, should remove
                                   (if (number? (ktv-value ktv))
                                       (number->string (ktv-value ktv))
                                       (ktv-value ktv)) "numeric"
578 579 580 581
                                   (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
582 583
    entity)
   (list
Dave Griffiths's avatar
Dave Griffiths committed
584 585
    (horiz
     (mbutton "review-item-cancel" "Cancel" (lambda () (list (finish-activity 0))))
586 587
     (mbutton (string-append uid "-save") "Save"
              (lambda ()
588 589 590 591 592 593 594 595 596 597 598
                (let ((new-entity (review-validate-contents uid (get-current 'entity-values '()))))
                  (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"
599
                      (string-append "Can't find mongoose or pack: " new-entity)
600 601 602 603 604
                      (lambda (v)
                        (cond
                         ((eqv? v 1) (list))
                         (else (list)))))))))))))))

Dave Griffiths's avatar
Dave Griffiths committed
605 606 607 608 609 610 611 612 613 614

(define (review-item-build)
  (let ((uid (entity-get-value "unique_id")))
    (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
615 616 617 618 619 620 621 622 623 624 625

(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
626
              (type (list-ref data 0))
Dave Griffiths's avatar
Dave Griffiths committed
627
              (uid (list-ref data 1)))
Dave Griffiths's avatar
Dave Griffiths committed
628 629 630 631 632 633
         (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
634 635
     (dirty-entities-for-review db "stream")))))

636 637
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
Dave Griffiths's avatar
Dave Griffiths committed
638

639 640 641 642
(define (debug! txt)
  (set-current! 'debug-text (string-append txt "\n" (get-current 'debug-text ""))))

(define (update-debug)
643 644 645
  (update-widget 'debug-text-view (get-id "sync-debug") 'text
                 (get-current 'debug-text "")))

646
(define (debug-timer-cb)
Dave Griffiths's avatar
Dave Griffiths committed
647 648 649 650 651 652 653
  (append
   (cond
    ((get-current 'sync-on #f)
     (set-current! 'upload 0)
     (set-current! 'download 0)
     (connect-to-net
      (lambda ()
654
        (msg "connected, going in...")
Dave Griffiths's avatar
Dave Griffiths committed
655 656 657
        (append
         (list (toast "sync-cb"))
         (upload-dirty db)
658 659 660 661 662 663
         ;; 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
664 665
    (else '()))
   (list
666
    (delayed "debug-timer" (+ 10000 (random 5000)) debug-timer-cb)
Dave Griffiths's avatar
Dave Griffiths committed
667
    (update-debug))))
668

669

670 671
(define pf-length 20) ;; minutes...

672 673 674 675 676 677 678
(define (timer-cb)
  (set-current!
   'timer-seconds
   (- (get-current 'timer-seconds 59) 1))
  (append
   (cond
    ((< (get-current 'timer-seconds 59) 0)
679
     (set-current! 'timer-minutes (- (get-current 'timer-minutes pf-length) 1))
680
     (set-current! 'timer-seconds 59)
681 682 683 684 685 686 687 688 689 690 691 692 693 694
     (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")))))
695 696 697 698 699
    (else '()))
   (list
    (delayed "timer" 1000 timer-cb)
    (update-widget
     'text-view (get-id "pf-timer-time-minutes") 'text
700
     (string-append (number->string (get-current 'timer-minutes pf-length))))
701 702 703 704 705
    (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
706
(define (next-button id dialog-msg last-frag next-frag fn)
707 708 709 710
  (vert
   (spacer 30)
   (horiz
    (mbutton (string-append id "-backb") "Back"
Dave Griffiths's avatar
Dave Griffiths committed
711 712 713
             (lambda ()
               (list (replace-fragment (get-id "gc-top") last-frag))))

714
    (mbutton (string-append id "-nextb") "Next"
Dave Griffiths's avatar
Dave Griffiths committed
715
             (lambda ()
716 717 718 719 720 721
               (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
722

723 724 725 726
(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
727

728

729
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
730

731
(define (update-selector-colours id entity-type where)
732
  (msg "update-selector-colours")
733 734 735 736 737 738 739
  (update-grid-selector-colours
   id "id-mongoose"
   (db-filter
    db "stream" entity-type
    (list
     (list "parent" "varchar" "=" (get-current 'group-composition-id 0))
     where))))
740

741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759
(define (update-selector-colours2 id entity-type where)
  (msg "update-selector-colours")
  (update-grid-selector-colours
   id "id-escort"
   (db-filter
    db "stream" entity-type
    (list
     (list "parent" "varchar" "=" (get-current 'group-composition-id 0))
     where))))

(define (update-selector-colours3 id entity-type)
  (msg "update-selector-colours")
  (update-grid-selector-colours
   id "id-mongoose"
   (db-filter
    db "stream" entity-type
    (list
     (list "parent" "varchar" "=" (get-current 'group-composition-id 0))))))

760 761
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; fragments
Dave Griffiths's avatar
Dave Griffiths committed
762 763 764

(define-fragment-list

765 766 767
  (fragment
   "pf-timer"
   (linear-layout
768
    (make-id "") 'vertical fillwrap trans-col
769
    (list
770
     (mtitle "pf-details" "Pack: xxx Pup: xxx")))
771 772 773
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
774 775 776 777 778 779
     (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"))
                     )))
780 781 782 783 784 785 786
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


  (fragment
787
   "events"
788
   (linear-layout
789
    0 'vertical fillwrap trans-col
790
    (list
791
     (linear-layout
Dave Griffiths's avatar
Dave Griffiths committed
792
      (make-id "ev-pf") 'vertical fill pf-col
793
      (list
794 795
       (mtitle "ev-pf-text" "Pup Focal Events")
       (horiz
Dave Griffiths's avatar
Dave Griffiths committed
796 797 798 799
        (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")))))))
800
     (linear-layout
801
      (make-id "ev-pf") 'vertical fill gp-col
802
      (list
803 804
       (mtitle "text" "Group Events")
       (horiz
Dave Griffiths's avatar
Dave Griffiths committed
805 806
        (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"))))
807 808
        (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")))))))))
809 810 811
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
812
     (if (equal? (get-current 'observation "none") obs-pf)
813 814
         (list
          (update-widget 'text-view (get-id "ev-pf-text") 'show 0)
Dave Griffiths's avatar
Dave Griffiths committed
815 816 817 818
          (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))))
819 820 821 822
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))
823

824 825 826
  (fragment
   "pf-scan1"
   (linear-layout
827
    (make-id "") 'vertical fillwrap pf-col
828
    (list
Dave Griffiths's avatar
Dave Griffiths committed
829
     (build-grid-selector "pf-scan-nearest" "single" "<b>Nearest Neighbour Scan</b>: Closest Mongoose")
830
     (build-grid-selector "pf-scan-close" "toggle" "Mongooses within 2m")
831 832
     (mbutton "pf-scan-done" "Done"
              (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
833
                (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
Dave Griffiths's avatar
Dave Griffiths committed
834
                (entity-record-values!)
835
                (list (replace-fragment (get-id "pf-top") "pf-timer"))))))
836 837 838 839

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
840
     (entity-init! db "stream" "pup-focal-nearest" '())
Dave Griffiths's avatar
Dave Griffiths committed
841
     (entity-set-value! "scan-time" "varchar" (date-time->string (date-time)))
842
     (list
843 844
      (play-sound "ping")
      (vibrate 300)
845
      (populate-grid-selector
846
       "pf-scan-nearest" "single"
847
       (db-mongooses-by-pack-adults) #t
848
       (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
849
         (entity-set-value! "id-nearest" "varchar" (ktv-get individual "unique_id"))
850 851
         (list)))
      (populate-grid-selector
852
       "pf-scan-close" "toggle"
853
       (db-mongooses-by-pack-adults) #t
854
       (lambda (individuals)
Dave Griffiths's avatar
Dave Griffiths committed
855
         (entity-set-value! "id-list-close" "varchar" (assemble-array individuals))
856 857
         (list)))
      ))
858 859 860 861 862 863
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


864 865 866
  (fragment
   "ev-pupfeed"
   (linear-layout
867
    (make-id "") 'vertical fillwrap pf-col
868
    (list
869
     (mtitle "title" "Event: Pup is fed")
870
     (build-grid-selector "pf-pupfeed-who" "single" "Who fed the pup?")
Dave Griffiths's avatar
Dave Griffiths committed
871
     (spacer 20)
872
     (horiz
Dave Griffiths's avatar
Dave Griffiths committed
873
      (mtext "text" "Food size")
874 875 876
      (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
877 878
     (spacer 20)
     (horiz
879 880
      (mbutton "pf-pupfeed-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
881
                 (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
Dave Griffiths's avatar
Dave Griffiths committed
882
                 (entity-record-values!)
883 884 885
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-pupfeed-cancel" "Cancel"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
886
                 (list (replace-fragment (get-id "event-holder") "events")))))))
887 888 889 890

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
891
     (entity-init!  db "stream" "pup-focal-pupfeed" '())
892 893 894
     (list
      (populate-grid-selector
       "pf-pupfeed-who" "single"
895
       (db-mongooses-by-pack-adults) #t
896
       (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
897
         (entity-set-value! "id-who" "varchar" (ktv-get individual "unique_id"))
898 899 900 901 902 903 904
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

Dave Griffiths's avatar
Dave Griffiths committed
905 906 907
  (fragment
   "ev-pupfind"
   (linear-layout
908
    (make-id "") 'vertical fillwrap pf-col
Dave Griffiths's avatar
Dave Griffiths committed
909
    (list
910
     (mtitle "title" "Event: Pup found food")
Dave Griffiths's avatar
Dave Griffiths committed
911 912
     (horiz
      (mtext "text" "Food size")
913 914
      (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
915
     (spacer 20)
Dave Griffiths's avatar
Dave Griffiths committed
916
     (horiz
917 918
      (mbutton "pf-pupfind-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
919
                 (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
Dave Griffiths's avatar
Dave Griffiths committed
920
                 (entity-record-values!)
921 922 923
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-pupfind-cancel" "Cancel"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
924
                 (list (replace-fragment (get-id "event-holder") "events")))))))
Dave Griffiths's avatar
Dave Griffiths committed
925 926 927 928

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
929
     (entity-init! db "stream" "pup-focal-pupfind" '())
Dave Griffiths's avatar
Dave Griffiths committed
930 931 932 933 934 935 936 937 938 939 940
     (list
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


  (fragment
   "ev-pupcare"
   (linear-layout
941
    (make-id "") 'vertical fillwrap pf-col
Dave Griffiths's avatar
Dave Griffiths committed
942
    (list
943
     (mtitle "title" "Event: Pup is cared for")
Dave Griffiths's avatar
Dave Griffiths committed
944
     (build-grid-selector "pf-pupcare-who" "single" "Who cared for the pup?")
Dave Griffiths's avatar
Dave Griffiths committed
945
     (spacer 20)
Dave Griffiths's avatar
Dave Griffiths committed
946
     (horiz
Dave Griffiths's avatar
Dave Griffiths committed
947
      (mtext "text" "Type of care")
948
      (mspinner "pf-pupcare-type" list-pupcare-type
949
               (lambda (v)
950
                 (entity-set-value! "type" "varchar" (spinner-choice list-pupcare-type v)) '())))
Dave Griffiths's avatar
Dave Griffiths committed
951 952
     (spacer 20)
     (horiz
953 954
      (mbutton "pf-pupcare-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
955
                 (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
Dave Griffiths's avatar
Dave Griffiths committed
956
                 (entity-record-values!)
957 958 959
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-pupcare-cancel" "Cancel"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
960
                 (list (replace-fragment (get-id "event-holder") "events")))))))
Dave Griffiths's avatar
Dave Griffiths committed
961 962 963 964

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
965
     (entity-init! db "stream" "pup-focal-pupcare" '())
Dave Griffiths's avatar
Dave Griffiths committed
966 967 968
     (list
      (populate-grid-selector
       "pf-pupcare-who" "single"
969
       (db-mongooses-by-pack-adults) #t
Dave Griffiths's avatar
Dave Griffiths committed
970
       (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
971
         (entity-set-value! "id-who" "varchar" (ktv-get individual "unique_id"))
Dave Griffiths's avatar
Dave Griffiths committed
972 973 974 975 976 977 978 979 980 981
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "ev-pupaggr"
   (linear-layout
982
    (make-id "") 'vertical fillwrap pf-col
Dave Griffiths's avatar
Dave Griffiths committed
983
    (list
984
     (mtitle "title" "Event: Pup aggression")
Dave Griffiths's avatar
Dave Griffiths committed
985 986 987
     (build-grid-selector "pf-pupaggr-partner" "single" "Aggressive mongoose")

     (linear-layout
988
      (make-id "") 'horizontal (layout 'fill-parent 100 '1 'left 0) trans-col
Dave Griffiths's avatar
Dave Griffiths committed
989 990 991
      (list
       (vert
        (mtext "" "Fighting over")
992 993 994
        (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
995 996
       (vert
        (mtext "" "Level")
997 998 999
        (mspinner "pf-pupaggr-level" list-aggression-level
                  (lambda (v)
                    (entity-set-value! "level" "varchar" (spinner-choice list-aggression-level v)) '())))
1000 1001 1002 1003 1004

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

       ;(mtoggle-button "pf-pupaggr-in" "Initiate?"
       ;                (lambda (v)
Dave Griffiths's avatar
Dave Griffiths committed
1005
       ;                  (entity-set-value! "initiate" "varchar" (if v "yes" "no")) '()))
1006 1007 1008 1009


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

Dave Griffiths's avatar
Dave Griffiths committed
1010
     (spacer 20)
1011 1012 1013
     (horiz
      (mbutton "pf-pupaggr-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
1014
                 (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
Dave Griffiths's avatar
Dave Griffiths committed