starwisp.scm 30.9 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16
;; 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/>.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Dave Griffiths's avatar
Dave Griffiths committed
17
;; persistent database
18

Dave Griffiths's avatar
Dave Griffiths committed
19 20
(define db "/sdcard/test.db")
(db-open db)
21 22 23 24 25 26 27 28 29 30
(setup db "local")
(setup db "sync")
(setup db "stream")

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

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

Dave Griffiths's avatar
Dave Griffiths committed
32 33
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; stuff in memory
Dave Griffiths's avatar
Dave Griffiths committed
34

Dave Griffiths's avatar
Dave Griffiths committed
35 36
(define (store-set store key value)
  (cond
37 38 39 40 41
   ((null? store) (list (list key value)))
   ((eq? key (car (car store)))
    (cons (list key value) (cdr store)))
   (else
    (cons (car store) (store-set (cdr store) key value)))))
Dave Griffiths's avatar
Dave Griffiths committed
42

Dave Griffiths's avatar
Dave Griffiths committed
43
(define (store-get store key default)
Dave Griffiths's avatar
Dave Griffiths committed
44
  (cond
45 46 47 48 49 50 51 52 53 54 55 56 57
   ((null? store) default)
   ((eq? key (car (car store)))
    (cadr (car store)))
   (else
    (store-get (cdr store) key default))))

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


Dave Griffiths's avatar
Dave Griffiths committed
60
(define store '())
Dave Griffiths's avatar
Dave Griffiths committed
61

Dave Griffiths's avatar
Dave Griffiths committed
62 63
(define (set-current! key value)
  (set! store (store-set store key value)))
Dave Griffiths's avatar
Dave Griffiths committed
64

Dave Griffiths's avatar
Dave Griffiths committed
65 66
(define (get-current key default)
  (store-get store key default))
Dave Griffiths's avatar
Dave Griffiths committed
67

68 69 70
(define (current-exists? key)
  (store-exists? store key))

Dave Griffiths's avatar
Dave Griffiths committed
71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; syncing code

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

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

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

(define (build-url-from-entity table e)
  (string-append
   url
   "fn=sync"
   "&table=" table
   "&entity-type=" (list-ref (car e) 0)
   "&unique-id=" (list-ref (car e) 1)
Dave Griffiths's avatar
Dave Griffiths committed
92 93
   "&dirty=" (number->string (list-ref (car e) 2))
   "&version=" (number->string (list-ref (car e) 3))
Dave Griffiths's avatar
Dave Griffiths committed
94 95 96 97 98 99 100 101 102 103 104 105
   (build-url-from-ktvlist (cadr e))))

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

112
(define (suck-entity-from-server db table unique-id exists)
Dave Griffiths's avatar
Dave Griffiths committed
113 114 115 116 117 118 119
  ;; ask for the current version
  (http-request
   (string-append unique-id "-update-new")
   (string-append url "fn=entity&table=" table "&unique-id=" unique-id)
   (lambda (data)
     (msg "data from server request" data)
     ;; check "sync-insert" in sync.ss raspberry pi-side for the contents of 'entity'
120 121
     (let ((entity (list-ref data 0))
           (ktvlist (list-ref data 1)))
Dave Griffiths's avatar
Dave Griffiths committed
122
       (if (not exists)
123 124 125 126 127 128 129 130
           (begin
             (insert-entity-wholesale
              db table
              (list-ref entity 0) ;; entity-type
              (list-ref entity 1) ;; unique-id
              0 ;; dirty
              (list-ref entity 2) ;; version
              ktvlist))
Dave Griffiths's avatar
Dave Griffiths committed
131 132
           (update-to-version
            db table (get-entity-id db table unique-id)
Dave Griffiths's avatar
Dave Griffiths committed
133 134 135 136
            (list-ref entity 4) ktvlist))
       (list
        (update-widget 'text-view (get-id "sync-dirty") 'text (build-dirty))
        (toast (string-append "Downloaded " (ktv-get ktvlist "name"))))))))
Dave Griffiths's avatar
Dave Griffiths committed
137

Dave Griffiths's avatar
Dave Griffiths committed
138
;; repeatedly read version and request updates
Dave Griffiths's avatar
Dave Griffiths committed
139
(define (suck-new db table)
Dave Griffiths's avatar
Dave Griffiths committed
140 141 142
  (list
   (http-request
    "new-entities-req"
143
    (string-append url "fn=entity-versions&table=" table)
Dave Griffiths's avatar
Dave Griffiths committed
144
    (lambda (data)
Dave Griffiths's avatar
Dave Griffiths committed
145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164
      (let ((r (foldl
                (lambda (i r)
                  (let* ((unique-id (car i))
                         (version (cadr i))
                         (exists (entity-exists? db table unique-id))
                         (old
                          (if exists
                              (> version (get-entity-version
                                          db table
                                          (get-entity-id db table unique-id)))
                              #f)))
                    ;; if we don't have this entity or the version on the server is newer
                    (if (or (not exists) old)
                        (cons (suck-entity-from-server db table unique-id exists) r)
                        r)))
                '()
                data)))
        (if (null? r)
            (cons (toast "All files up to date") r)
            (cons (toast "Requesting " (length r) " entities") r)))))))
Dave Griffiths's avatar
Dave Griffiths committed
165

166 167 168 169 170 171 172 173 174
(define (build-dirty)
  (let ((sync (get-dirty-stats db "sync"))
        (stream (get-dirty-stats db "stream")))
    (msg sync stream)
    (string-append
     "Pack data: " (number->string (car sync)) "/" (number->string (cadr sync)) " "
     "Focal data: " (number->string (car stream)) "/" (number->string (cadr stream)))))


Dave Griffiths's avatar
Dave Griffiths committed
175
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
176
;; user interface abstraction
Dave Griffiths's avatar
Dave Griffiths committed
177

Dave Griffiths's avatar
Dave Griffiths committed
178 179 180
(define (mbutton id title fn)
  (button (make-id id) title 20 fillwrap fn))

181 182 183
(define (mtoggle-button id title fn)
  (toggle-button (make-id id) title 20 fillwrap fn))

Dave Griffiths's avatar
Dave Griffiths committed
184 185
(define (mtext id text)
  (text-view (make-id id) text 20 fillwrap))
186

187 188 189 190 191 192 193 194 195 196 197
(define (medit-text id text type fn)
  (vert
   (text-view (make-id (string-append id "-title")) text 20 type fillwrap)
   (edit-text (make-id id) "" 30 fillwrap fn)))

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

198 199 200 201 202 203 204 205 206 207
(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))

208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269
(define (build-grid-selector name title)
  (vert
   (mtext "foo" title)
   (horiz
    (image-view (make-id "im") "arrow_left" (layout 100 'fill-parent 1 'left))
    (scroll-view
     (make-id "scroller")
     (layout 'wrap-content 'wrap-content 1 'left)
     (list
      (linear-layout
       (make-id name) 'horizontal
       (layout 'wrap-content 'wrap-content 1 'centre) (list))))
    (image-view (make-id "im") "arrow_right" (layout 100 'fill-parent 1 'right)))))

(define (populate-grid-selector name items fn)
  (update-widget
   'linear-layout (get-id name) 'contents
   (map
    (lambda (items)
      ;; todo add space for empty parts
      (linear-layout
       (make-id "foo") 'vertical wrap
       (map
        (lambda (item)
          (let ((item-name (ktv-get item "name")))
            (button (make-id (string-append name item-name))
                    item-name 20 (layout 100 60 1 'left)
                    (lambda ()
                      (fn item)))))
        items)))
    (xwise 3 items))))

(define (populate-grid-selector-single name items fn)
  (update-widget
   'linear-layout (get-id name) 'contents
   (map
    (lambda (chopped-items)
      ;; todo add space for empty parts
      (linear-layout
       (make-id "foo") 'vertical wrap
       (map
        (lambda (item)
          (let ((item-name (ktv-get item "name")))
            (toggle-button (make-id (string-append name item-name))
                    item-name 20 (layout 100 60 1 'left)
                    (lambda (v)
                      (append
                       ;; clear all the others except us
                       (mclear-toggles
                        (foldl
                         (lambda (item r)
                           (let ((tname (ktv-get item "name")))
                             (if (equal? tname item-name) r
                                 (cons
                                  (string-append name tname) r))))
                         '() items))
                       (fn item))))))
        chopped-items)))
    (xwise 3 items))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
Dave Griffiths's avatar
Dave Griffiths committed
270

271 272
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; fragments
Dave Griffiths's avatar
Dave Griffiths committed
273 274 275 276

(define-fragment-list

  (fragment
277
   "gc-start"
Dave Griffiths's avatar
Dave Griffiths committed
278
   (vert
279 280 281 282 283
;    (mtoggle-button "gc-main-obs" "Main observer" (lambda (v) '()))
;    (medit-text "gc-code" "Code" "numeric" (lambda (v) '()))
;    (build-grid-selector "gc-present" "Who's present?")
    (mbutton "gc-save" "Save" (lambda () '())))

Dave Griffiths's avatar
Dave Griffiths committed
284 285 286 287 288 289 290 291 292 293
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  )

294 295 296 297
(msg "one")

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

299 300 301 302 303
(define-activity-list
  (activity
   "splash"
   (vert
    (text-view (make-id "splash-title") "Mongoose 2000" 40 fillwrap)
Dave Griffiths's avatar
Dave Griffiths committed
304
    (mtext "splash-about" "Advanced mongoose technology")
305
    (spacer 20)
306
    (mbutton "f2" "Get started!" (lambda () (list (start-activity-goto "main" 2 "")))))
Dave Griffiths's avatar
Dave Griffiths committed
307

308 309 310 311 312 313 314 315 316
   (lambda (activity arg)
     (activity-layout activity))
   (lambda (activity arg) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity requestcode resultcode) '()))

Dave Griffiths's avatar
Dave Griffiths committed
317

318 319 320
  (activity
   "main"
   (vert
Dave Griffiths's avatar
Dave Griffiths committed
321 322
    (text-view (make-id "main-title") "Mongoose 2000" 40 fillwrap)
    (text-view (make-id "main-about") "Advanced mongoose technology" 20 fillwrap)
323
    (spacer 10)
324
    (mbutton "main-observations" "Observations" (lambda () (list (start-activity "observations" 2 ""))))
Dave Griffiths's avatar
Dave Griffiths committed
325 326
    (mbutton "main-manage" "Manage Packs" (lambda () (list (start-activity "manage-packs" 2 ""))))
    (mbutton "main-tag" "Tag Location" (lambda () (list (start-activity "tag-location" 2 ""))))
327
    (mtext "foo" "Your ID")
Dave Griffiths's avatar
Dave Griffiths committed
328
    (edit-text (make-id "main-id-text") "" 30 "text" fillwrap
329 330 331 332
               (lambda (v)
                 (set-current! 'user-id v)
                 (update-entity
                  db "local" 1 (list (ktv "user-id" "varchar" v)))))
Dave Griffiths's avatar
Dave Griffiths committed
333 334 335
    (mtext "foo" "Database")
    (horiz
     (mbutton "main-send" "Email" (lambda () (list)))
336
     (mbutton "main-sync" "Sync" (lambda () (list (start-activity "sync" 0 ""))))))
Dave Griffiths's avatar
Dave Griffiths committed
337 338
   (lambda (activity arg)
     (activity-layout activity))
339 340 341 342 343
   (lambda (activity arg)
     (let ((user-id (ktv-get (get-entity db "local" 1) "user-id")))
       (set-current! 'user-id user-id)
       (list
        (update-widget 'edit-text (get-id "main-id-text") 'text user-id))))
Dave Griffiths's avatar
Dave Griffiths committed
344 345 346 347 348 349 350
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity requestcode resultcode) '()))

  (activity
351
   "observations"
Dave Griffiths's avatar
Dave Griffiths committed
352
   (vert
353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375
    (text-view (make-id "title") "Start Observation" 40 fillwrap)
    (vert
     (mtext "type" "Choose observation type")
     (mtoggle-button "choose-obs-gc" "Group Composition"
              (lambda ()
                (set-current! 'observation "Group Composition")
                (mclear-toggles (list "obs-pf"))))
     (mtoggle-button "choose-obs-pf" "Pup Focal"
              (lambda ()
                (set-current! 'observation "Pup Focal")
                (mclear-toggles (list "obs-gc")))))
    (build-grid-selector "choose-obs-pack-selector" "Choose pack")
    (mbutton
     "choose-obs-start" "Start"
     (lambda ()
       (if (and (current-exists? 'pack)
                (current-exists? 'observation))
           (list (start-activity "observation" 2 ""))
           (list
            (alert-dialog
             "choose-obs-finish"
             "Need to specify a pack and an observation"
             (lambda () '()))))))
Dave Griffiths's avatar
Dave Griffiths committed
376 377 378
    )
   (lambda (activity arg)
     (activity-layout activity))
379 380 381 382 383 384
   (lambda (activity arg)
     (list
      (populate-grid-selector-single
       "choose-obs-pack-selector" (db-all db "sync" "pack")
       (lambda (pack)
         (set-current! 'pack pack)))))
Dave Griffiths's avatar
Dave Griffiths committed
385 386 387 388 389 390
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity requestcode resultcode) '()))

391 392


Dave Griffiths's avatar
Dave Griffiths committed
393
  (activity
394
   "observation"
Dave Griffiths's avatar
Dave Griffiths committed
395
   (vert
396
    (text-view (make-id "obs-title") "" 40 fillwrap)
Dave Griffiths's avatar
Dave Griffiths committed
397 398 399 400
    )

   (lambda (activity arg)
     (activity-layout activity))
401 402
   (lambda (activity arg)
     (list
403 404 405 406
      (update-widget 'text-view (get-id "obs-title") 'text
                     (string-append
                      (get-current 'observation "No observation")
                      " with " (ktv-get (get-current 'pack '()) "name")))
407
      ))
Dave Griffiths's avatar
Dave Griffiths committed
408 409 410 411 412 413
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity requestcode resultcode) '()))

414 415 416 417 418





Dave Griffiths's avatar
Dave Griffiths committed
419 420 421 422 423
  (activity
   "individual-select"
   (vert
    (text-view (make-id "title") "Select an individual" 40 fillwrap)
    (spacer 10)
424 425 426
    (linear-layout
     (make-id "individual-select-list")
     'vertical fill (list))
Dave Griffiths's avatar
Dave Griffiths committed
427 428 429
    )
   (lambda (activity arg)
     (activity-layout activity))
430 431 432 433 434 435 436 437
   (lambda (activity arg)
     (list
      (update-widget 'linear-layout (get-id "individual-select-list") 'contents
                     (build-individual-buttons
                      "ind-select"
                      (lambda (individual)
                        (set-current! 'individual individual)
                        (list (start-activity "pup-focal" 2 "")))))))
Dave Griffiths's avatar
Dave Griffiths committed
438 439 440 441 442 443 444
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity requestcode resultcode) '()))


Dave Griffiths's avatar
Dave Griffiths committed
445
  (let ((clear-focal-toggles
446
         (lambda (v but)
Dave Griffiths's avatar
Dave Griffiths committed
447
           (list
448 449 450 451 452 453 454
            (update-widget 'toggle-button (get-id "pup-focal-moving") 'checked
                           (if (equal? but "pup-focal-moving") 1 0))
            (update-widget 'toggle-button (get-id "pup-focal-foraging") 'checked
                           (if (equal? but "pup-focal-foraging") 1 0))
            (update-widget 'toggle-button (get-id "pup-focal-resting") 'checked
                           (if (equal? but "pup-focal-resting") 1 0)))
           )))
Dave Griffiths's avatar
Dave Griffiths committed
455

Dave Griffiths's avatar
Dave Griffiths committed
456 457 458 459 460 461 462 463
    (activity
     "pup-focal"
     (vert
      (horiz
       (text-view (make-id "pup-focal-title") "Pup Focal" 40 fillwrap)
       (vert
        (text-view (make-id "pup-focal-timer-text") "Time left" 20 fillwrap)
        (text-view (make-id "pup-focal-timer") "30" 40 fillwrap)))
464
      (text-view (make-id "pup-focal-name/pack") "" 25 fillwrap)
Dave Griffiths's avatar
Dave Griffiths committed
465 466
      (text-view (make-id "pup-focal") "Current Activity" 20 fillwrap)
      (horiz
467 468 469
       (toggle-button (make-id "pup-focal-moving") "Moving" 20 fillwrap (lambda (v) (clear-focal-toggles v "pup-focal-moving")))
       (toggle-button (make-id "pup-focal-foraging") "Foraging" 20 fillwrap (lambda (v) (clear-focal-toggles v "pup-focal-foraging")))
       (toggle-button (make-id "pup-focal-resting") "Resting" 20 fillwrap (lambda (v) (clear-focal-toggles v "pup-focal-resting"))))
Dave Griffiths's avatar
Dave Griffiths committed
470
      (text-view (make-id "pup-focal-escort-text") "Current Escort" 20 fillwrap)
471 472
      (spinner (make-id "pup-focal-escort") (list "mongoose1" "mongoose2")
                 fillwrap (lambda (v) '()))
Dave Griffiths's avatar
Dave Griffiths committed
473 474 475 476 477 478
      (horiz
       (button (make-id "pup-focal-event") "New event" 20 fillwrap (lambda () (list (start-activity "pup-focal-event" 2 ""))))
       (toggle-button (make-id "pup-focal-pause") "Pause" 20 fillwrap (lambda (v) '()))
       ))
     (lambda (activity arg)
       (activity-layout activity))
479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495
     (lambda (activity arg)
       (list
        (update-widget 'text-view (get-id "pup-focal-name/pack") 'text
                       (string-append
                        "Pack: " (ktv-get (get-current 'pack '()) "name") " "
                        "Pup: " (ktv-get (get-current 'individual '()) "name")))
        (update-widget 'spinner (get-id "pup-focal-escort") 'array
                 (foldl
                  (lambda (individual r)
                    (let ((name (ktv-get individual "name")))
                      (if (equal? name (ktv-get (get-current 'individual '()) "name"))
                          r (cons name r))))
                  '()
                  (dbg (db-all-where
                   db "sync" "mongoose"
                   (list "pack-id" (ktv-get (get-current 'pack '()) "unique_id"))))))
        ))
Dave Griffiths's avatar
Dave Griffiths committed
496 497 498 499 500
     (lambda (activity) '())
     (lambda (activity) '())
     (lambda (activity) '())
     (lambda (activity) '())
     (lambda (activity requestcode resultcode) '())))
Dave Griffiths's avatar
Dave Griffiths committed
501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528

  (activity
   "pup-focal-event"
   (vert
    (text-view (make-id "main-title") "Pup focal event" 40 fillwrap)
    (spacer 10)
    (button (make-id "event-self") "Self feeding" 20 fillwrap
            (lambda () (list (start-activity "event-self" 2 ""))))
    (button (make-id "event-fed") "Being fed" 20 fillwrap
            (lambda () (list (start-activity "event-fed" 2 ""))))
    (button (make-id "event-aggression") "Aggression" 20 fillwrap
            (lambda () (list (start-activity "event-aggression" 2 ""))))
    (spacer 10)
    (button (make-id "event-cancel") "Cancel" 20 fillwrap
            (lambda () (list (finish-activity 0))))
    )
   (lambda (activity arg)
     (activity-layout activity))
   (lambda (activity arg) (list))
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity requestcode resultcode) '()))

  (activity
   "event-self"
   (vert
Dave Griffiths's avatar
Dave Griffiths committed
529
    (text-view (make-id "main-title") "Self feeding event" 40 fillwrap)
Dave Griffiths's avatar
Dave Griffiths committed
530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557
    (spacer 10)
    (toggle-button (make-id "event-self-found") "Found item?" 20 fillwrap
                   (lambda (v) '()))
    (toggle-button (make-id "event-self-kept") "Kept item?" 20 fillwrap
                   (lambda (v) '()))

    (text-view (make-id "event-self-type-text") "Food type" 20 fillwrap)
    (spinner (make-id "event-self-type") (list "Beetle" "Millipede") fillwrap (lambda (v) '()))

    (text-view (make-id "event-self-type-text") "Food size" 20 fillwrap)
    (spinner (make-id "event-self-type") (list "Small" "Medium" "Large") fillwrap (lambda (v) '()))
    (spacer 10)
    (horiz
     (button (make-id "event-self-cancel") "Cancel" 20 fillwrap (lambda () (list (finish-activity 0))))
     (button (make-id "event-self-done") "Done" 20 fillwrap (lambda () (list (finish-activity 0)))))
    )
   (lambda (activity arg)
     (activity-layout activity))
   (lambda (activity arg) (list))
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity requestcode resultcode) '()))

  (activity
   "event-fed"
   (vert
Dave Griffiths's avatar
Dave Griffiths committed
558
    (text-view (make-id "main-title") "Being fed event" 40 fillwrap)
Dave Griffiths's avatar
Dave Griffiths committed
559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589
    (spacer 10)
    (text-view (make-id "event-fed-who-text") "Who by" 20 fillwrap)
    (spinner (make-id "event-fed-who") (list "Mongoose 1" "Mongoose 2" "Mongoose 3") fillwrap (lambda (v) '()))
    (toggle-button (make-id "event-fed-closest") "Closest to feeder?" 20 fillwrap
                   (lambda (v) '()))

    (text-view (make-id "event-self-type-text") "Who moved?" 20 fillwrap)
    (spinner (make-id "event-self-type") (list "Pup" "Feeder") fillwrap (lambda (v) '()))

    (text-view (make-id "event-fed-type-text") "Food type" 20 fillwrap)
    (spinner (make-id "event-fed-type") (list "Beetle" "Millipede") fillwrap (lambda (v) '()))

    (text-view (make-id "event-fed-type-text") "Food size" 20 fillwrap)
    (spinner (make-id "event-fed-type") (list "Small" "Medium" "Large") fillwrap (lambda (v) '()))
    (spacer 10)
    (horiz
     (button (make-id "event-fed-cancel") "Cancel" 20 fillwrap (lambda () (list (finish-activity 0))))
     (button (make-id "event-fed-done") "Done" 20 fillwrap (lambda () (list (finish-activity 0)))))
    )
   (lambda (activity arg)
     (activity-layout activity))
   (lambda (activity arg) (list))
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity requestcode resultcode) '()))

  (activity
   "event-aggression"
   (vert
Dave Griffiths's avatar
Dave Griffiths committed
590
    (text-view (make-id "main-title") "Aggression event" 40 fillwrap)
Dave Griffiths's avatar
Dave Griffiths committed
591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616
    (spacer 10)
    (text-view (make-id "event-agg-who-text") "Other individual" 20 fillwrap)
    (spinner (make-id "event-agg-who") (list "Mongoose 1" "Mongoose 2" "Mongoose 3") fillwrap (lambda (v) '()))
    (text-view (make-id "event-agg-severity-text") "Severity" 20 fillwrap)
    (seek-bar (make-id "event-agg-severity") 100 fillwrap (lambda (v) '()))
    (spacer 10)
    (horiz
     (button (make-id "event-agg-cancel") "Cancel" 20 fillwrap (lambda () (list (finish-activity 0))))
     (button (make-id "event-agg-done") "Done" 20 fillwrap (lambda () (list (finish-activity 0)))))
    )
   (lambda (activity arg)
     (activity-layout activity))
   (lambda (activity arg) (list))
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity requestcode resultcode) '()))


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

  (activity
   "manage-packs"
   (vert
    (text-view (make-id "title") "Manage packs" 40 fillwrap)
617
    (build-grid-selector "manage-packs-list" "Choose pack")
Dave Griffiths's avatar
Dave Griffiths committed
618
    (button (make-id "manage-packs-new") "New pack" 20 fillwrap (lambda () (list (start-activity "new-pack" 2 ""))))
Dave Griffiths's avatar
Dave Griffiths committed
619 620 621
    )
   (lambda (activity arg)
     (activity-layout activity))
Dave Griffiths's avatar
Dave Griffiths committed
622 623
   (lambda (activity arg)
     (list
624 625 626 627 628
      (populate-grid-selector
       "manage-packs-list" (db-all db "sync" "pack")
       (lambda (pack)
         (set-current! 'pack pack)
         (list (start-activity "manage-individual" 2 ""))))
Dave Griffiths's avatar
Dave Griffiths committed
629
      ))
Dave Griffiths's avatar
Dave Griffiths committed
630 631 632 633
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
634
   (lambda (activity requestcode resultcode) '()))
Dave Griffiths's avatar
Dave Griffiths committed
635 636 637 638 639 640

  (activity
   "new-pack"
   (vert
    (text-view (make-id "title") "New pack" 40 fillwrap)
    (spacer 10)
Dave Griffiths's avatar
Dave Griffiths committed
641
    (text-view (make-id "new-pack-name-text") "Pack name" 20 fillwrap)
Dave Griffiths's avatar
Dave Griffiths committed
642
    (edit-text (make-id "new-pack-name") "" 30 "text" fillwrap
643
               (lambda (v) (set-current! 'pack-name v) '()))
Dave Griffiths's avatar
Dave Griffiths committed
644
    (spacer 10)
Dave Griffiths's avatar
Dave Griffiths committed
645 646 647 648 649
    (horiz
     (button (make-id "new-pack-cancel") "Cancel" 20 fillwrap (lambda () (list (finish-activity 2))))
     (button (make-id "new-pack-done") "Done" 20 fillwrap
             (lambda ()
               (insert-entity
Dave Griffiths's avatar
Dave Griffiths committed
650
                db "sync" "pack" (get-current 'user-id "no id")
651
                (list
Dave Griffiths's avatar
Dave Griffiths committed
652
                 (ktv "name" "varchar" (get-current 'pack-name "no name"))))
Dave Griffiths's avatar
Dave Griffiths committed
653
               (list (finish-activity 2)))))
Dave Griffiths's avatar
Dave Griffiths committed
654 655 656 657 658 659 660 661 662 663 664
    )
   (lambda (activity arg)
     (activity-layout activity))
   (lambda (activity arg) (list))
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity requestcode resultcode) '()))

  (activity
Dave Griffiths's avatar
Dave Griffiths committed
665
   "manage-individual"
Dave Griffiths's avatar
Dave Griffiths committed
666 667
   (vert
    (text-view (make-id "title") "Manage individuals" 40 fillwrap)
Dave Griffiths's avatar
Dave Griffiths committed
668
    (text-view (make-id "manage-individual-pack-name") "Pack:" 20 fillwrap)
669
    (build-grid-selector "manage-individuals-list" "Choose individual")
Dave Griffiths's avatar
Dave Griffiths committed
670
    (button (make-id "manage-individuals-new") "New individual" 20 fillwrap (lambda () (list (start-activity "new-individual" 2 ""))))
Dave Griffiths's avatar
Dave Griffiths committed
671 672 673
    )
   (lambda (activity arg)
     (activity-layout activity))
Dave Griffiths's avatar
Dave Griffiths committed
674 675
   (lambda (activity arg)
     (list
676 677 678 679 680
      (populate-grid-selector
       "manage-individuals-list"
       (db-all-where db "sync" "mongoose" (list "pack-id" (ktv-get (get-current 'pack '()) "unique_id")))
       (lambda (individual)
         (list (start-activity "manage-individual" 2 ""))))
Dave Griffiths's avatar
Dave Griffiths committed
681
      (update-widget 'text-view (get-id "manage-individual-pack-name") 'text
Dave Griffiths's avatar
Dave Griffiths committed
682
                     (string-append "Pack: " (ktv-get (get-current 'pack '()) "name")))
Dave Griffiths's avatar
Dave Griffiths committed
683
      ))
Dave Griffiths's avatar
Dave Griffiths committed
684 685 686 687
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
688
   (lambda (activity requestcode resultcode) '()))
Dave Griffiths's avatar
Dave Griffiths committed
689 690 691 692 693

  (activity
   "new-individual"
   (vert
    (text-view (make-id "title") "New Mongoose" 40 fillwrap)
Dave Griffiths's avatar
Dave Griffiths committed
694
    (text-view (make-id "new-individual-pack-name") "Pack:" 20 fillwrap)
Dave Griffiths's avatar
Dave Griffiths committed
695
    (text-view (make-id "new-individual-name-text") "Name" 20 fillwrap)
Dave Griffiths's avatar
Dave Griffiths committed
696
    (edit-text (make-id "new-individual-name") "" 30 "text" fillwrap
Dave Griffiths's avatar
Dave Griffiths committed
697
               (lambda (v) (set-current! 'individual-name v) '()))
Dave Griffiths's avatar
Dave Griffiths committed
698
    (text-view (make-id "new-individual-name-text") "Gender" 20 fillwrap)
Dave Griffiths's avatar
Dave Griffiths committed
699 700
    (spinner (make-id "new-individual-gender") (list "Female" "Male") fillwrap
             (lambda (v) (set-current! 'individual-gender v) '()))
Dave Griffiths's avatar
Dave Griffiths committed
701
    (text-view (make-id "new-individual-dob-text") "Date of Birth" 20 fillwrap)
Dave Griffiths's avatar
Dave Griffiths committed
702 703 704
    (horiz
     (text-view (make-id "new-individual-dob") "00/00/00" 25 fillwrap)
     (button (make-id "date") "Set date" 20 fillwrap (lambda () '())))
Dave Griffiths's avatar
Dave Griffiths committed
705
    (text-view (make-id "new-individual-litter-text") "Litter code" 20 fillwrap)
Dave Griffiths's avatar
Dave Griffiths committed
706
    (edit-text (make-id "new-individual-litter-code") "" 30 "text" fillwrap
Dave Griffiths's avatar
Dave Griffiths committed
707
               (lambda (v) (set-current! 'individual-litter-code v) '()))
Dave Griffiths's avatar
Dave Griffiths committed
708
    (text-view (make-id "new-individual-chip-text") "Chip code" 20 fillwrap)
Dave Griffiths's avatar
Dave Griffiths committed
709
    (edit-text (make-id "new-individual-chip-code") "" 30 "text" fillwrap
Dave Griffiths's avatar
Dave Griffiths committed
710 711 712 713 714 715
               (lambda (v) (set-current! 'individual-chip-code v) '()))
    (horiz
     (button (make-id "new-individual-cancel") "Cancel" 20 fillwrap (lambda () (list (finish-activity 2))))
     (button (make-id "new-individual-done") "Done" 20 fillwrap
             (lambda ()
               (insert-entity
Dave Griffiths's avatar
Dave Griffiths committed
716
                db "sync" "mongoose" (get-current 'user-id "no id")
717
                (list
Dave Griffiths's avatar
Dave Griffiths committed
718 719 720 721 722
                 (ktv "name" "varchar" (get-current 'individual-name "no name"))
                 (ktv "gender" "varchar" (get-current 'individual-gender "Female"))
                 (ktv "litter-code" "varchar" (get-current 'individual-litter-code ""))
                 (ktv "chip-code" "varchar" (get-current 'individual-chip-code ""))
                 (ktv "pack-id" "varchar" (ktv-get (get-current 'pack '()) "unique_id"))
723
                 ))
Dave Griffiths's avatar
Dave Griffiths committed
724
               (list (finish-activity 2)))))
725 726 727
    )
   (lambda (activity arg)
     (activity-layout activity))
Dave Griffiths's avatar
Dave Griffiths committed
728 729 730
   (lambda (activity arg)
     (list
      (update-widget 'text-view (get-id "new-individual-pack-name") 'text
Dave Griffiths's avatar
Dave Griffiths committed
731
                     (string-append "Pack: " (ktv-get (get-current 'pack '()) "name")))))
732 733 734 735
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
Dave Griffiths's avatar
Dave Griffiths committed
736 737 738 739 740 741 742
   (lambda (activity requestcode resultcode) '()))

  (activity
   "update-individual"
   (vert
    (text-view (make-id "title") "Update Mongoose" 40 fillwrap)
    (spacer 10)
Dave Griffiths's avatar
Dave Griffiths committed
743
    (text-view (make-id "update-individual-name-text") "Name" 20 fillwrap)
Dave Griffiths's avatar
Dave Griffiths committed
744
    (edit-text (make-id "update-individual-name") "" 30 "text" fillwrap (lambda (v) '()))
Dave Griffiths's avatar
Dave Griffiths committed
745
    (text-view (make-id "update-individual-name-text") "Gender" 20 fillwrap)
Dave Griffiths's avatar
Dave Griffiths committed
746
    (spinner (make-id "update-individual-gender") (list "Female" "Male") fillwrap (lambda (v) '()))
Dave Griffiths's avatar
Dave Griffiths committed
747
    (text-view (make-id "update-individual-dob-text") "Date of Birth" 20 fillwrap)
Dave Griffiths's avatar
Dave Griffiths committed
748 749 750
    (horiz
     (text-view (make-id "update-individual-dob") "00/00/00" 25 fillwrap)
     (button (make-id "date") "Set date" 20 fillwrap (lambda () '())))
Dave Griffiths's avatar
Dave Griffiths committed
751
    (text-view (make-id "update-individual-litter-text") "Litter code" 20 fillwrap)
Dave Griffiths's avatar
Dave Griffiths committed
752
    (edit-text (make-id "update-individual-litter-code") "" 30 "text" fillwrap (lambda (v) '()))
Dave Griffiths's avatar
Dave Griffiths committed
753
    (text-view (make-id "update-individual-chip-text") "Chip code" 20 fillwrap)
Dave Griffiths's avatar
Dave Griffiths committed
754
    (edit-text (make-id "update-individual-chip-code") "" 30 "text" fillwrap (lambda (v) '()))
Dave Griffiths's avatar
Dave Griffiths committed
755 756
    (spacer 10)
    (horiz
Dave Griffiths's avatar
Dave Griffiths committed
757 758
     (button (make-id "update-individual-delete") "Delete" 20 fillwrap (lambda () (list (finish-activity 2))))
     (button (make-id "update-individual-died") "Died" 20 fillwrap (lambda () (list (finish-activity 2)))))
Dave Griffiths's avatar
Dave Griffiths committed
759
    (horiz
Dave Griffiths's avatar
Dave Griffiths committed
760 761
     (button (make-id "update-individual-cancel") "Cancel" 20 fillwrap (lambda () (list (finish-activity 2))))
     (button (make-id "update-individual-done") "Done" 20 fillwrap (lambda () (list (finish-activity 2)))))
Dave Griffiths's avatar
Dave Griffiths committed
762 763 764 765 766 767 768 769 770 771 772 773 774 775 776
    )
   (lambda (activity arg)
     (activity-layout activity))
   (lambda (activity arg) (list))
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity requestcode resultcode) '()))


  (activity
   "tag-location"
   (vert
    (text-view (make-id "title") "Tag Location" 40 fillwrap)
Dave Griffiths's avatar
Dave Griffiths committed
777
    (text-view (make-id "tag-location-gps-text") "GPS" 20 fillwrap)
Dave Griffiths's avatar
Dave Griffiths committed
778
    (horiz
Dave Griffiths's avatar
Dave Griffiths committed
779 780
     (text-view (make-id "tag-location-gps-lat") "LAT" 20 fillwrap)
     (text-view (make-id "tag-location-gps-lng") "LNG" 20 fillwrap))
Dave Griffiths's avatar
Dave Griffiths committed
781

Dave Griffiths's avatar
Dave Griffiths committed
782
    (text-view (make-id "tag-location-name-text") "Name" 20 fillwrap)
Dave Griffiths's avatar
Dave Griffiths committed
783
    (edit-text (make-id "tag-location-name") "" 30 "text" fillwrap (lambda (v) '()))
Dave Griffiths's avatar
Dave Griffiths committed
784

Dave Griffiths's avatar
Dave Griffiths committed
785
    (text-view (make-id "tag-location-pack-text") "Associated pack" 20 fillwrap)
Dave Griffiths's avatar
Dave Griffiths committed
786 787 788 789 790 791 792
    (spinner (make-id "tag-location-pack") (list "Pack 1" "Pack 2") fillwrap (lambda (v) '()))

    (text-view (make-id "tag-location-radius-text") "Approx radius of area" 20 fillwrap)
    (seek-bar (make-id "tag-location-radius") 100 fillwrap (lambda (v) '()))
    (text-view (make-id "tag-location-radius-value") "10m" 20 fillwrap)

    (horiz
Dave Griffiths's avatar
Dave Griffiths committed
793 794
     (button (make-id "tag-location-cancel") "Cancel" 20 fillwrap (lambda () (list (finish-activity 2))))
     (button (make-id "tag-location-done") "Done" 20 fillwrap (lambda () (list (finish-activity 2)))))
Dave Griffiths's avatar
Dave Griffiths committed
795 796 797 798 799 800 801 802 803 804 805 806

    )
   (lambda (activity arg)
     (activity-layout activity))
   (lambda (activity arg) (list))
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity requestcode resultcode) '()))


Dave Griffiths's avatar
Dave Griffiths committed
807 808 809 810 811 812 813 814 815 816 817 818 819
  (activity
   "sync"
   (vert
    (text-view (make-id "sync-title") "Sync database" 40 fillwrap)
    (mtext "sync-dirty" "...")
    (horiz
     (mbutton "sync-connect" "Connect"
              (lambda ()
                (list
                 (network-connect
                  "network"
                  "mongoose-web"
                  (lambda (state)
820 821
                      (list
                       (update-widget 'text-view (get-id "sync-connect") 'text state)))))))
Dave Griffiths's avatar
Dave Griffiths committed
822 823 824 825 826 827 828 829 830 831 832
     (mbutton "sync-sync" "Push"
              (lambda ()
                (let ((r (spit-dirty db "sync")))
                  (cons (if (> (length r) 0)
                            (toast "Uploading data...")
                            (toast "No data changed to upload")) r))))
     (mbutton "sync-pull" "Pull"
              (lambda ()
                (cons (toast "Downloading data...") (suck-new db "sync")))))
    (text-view (make-id "sync-console") "..." 15 (layout 300 'wrap-content 1 'left))
    (mbutton "main-send" "Done" (lambda () (list (finish-activity 2)))))
Dave Griffiths's avatar
Dave Griffiths committed
833

Dave Griffiths's avatar
Dave Griffiths committed
834 835 836 837 838 839 840 841 842 843 844 845
   (lambda (activity arg)
     (activity-layout activity))
   (lambda (activity arg)
     (list
      (update-widget 'text-view (get-id "sync-dirty") 'text (build-dirty))
      ;;(update-widget 'text-view (get-id "sync-console") 'text (build-sync-debug db "sync"))
      ))
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity requestcode resultcode) '()))
Dave Griffiths's avatar
Dave Griffiths committed
846

847
  )