starwisp.scm 63.4 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
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; strings

19 20
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; fragments
Dave Griffiths's avatar
Dave Griffiths committed
21 22 23

(define-fragment-list

24 25 26
  (fragment
   "pf-timer"
   (linear-layout
27
    (make-id "") 'vertical fillwrap trans-col
28
    (list
29
     (mtitle "pf-details" "Pack: xxx Pup: xxx")))
30 31 32
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
33 34 35 36 37 38
     (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"))
                     )))
39 40 41 42 43 44 45
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


  (fragment
46
   "events"
47
   (linear-layout
48
    0 'vertical fillwrap trans-col
49
    (list
50
     (linear-layout
Dave Griffiths's avatar
Dave Griffiths committed
51
      (make-id "ev-pf") 'vertical fill pf-col
52
      (list
53 54
       (mtitle "ev-pf-text" "Pup Focal Events")
       (horiz
Dave Griffiths's avatar
Dave Griffiths committed
55 56 57 58
        (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")))))))
59
     (linear-layout
60
      (make-id "ev-pf") 'vertical fill gp-col
61
      (list
62 63
       (mtitle "text" "Group Events")
       (horiz
Dave Griffiths's avatar
Dave Griffiths committed
64 65
        (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"))))
66 67
        (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")))))))))
68 69 70
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
71
     (if (equal? (get-current 'observation "none") obs-pf)
72 73
         (list
          (update-widget 'text-view (get-id "ev-pf-text") 'show 0)
Dave Griffiths's avatar
Dave Griffiths committed
74 75 76 77
          (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))))
78 79 80 81
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))
82

83 84 85
  (fragment
   "pf-scan1"
   (linear-layout
86
    (make-id "") 'vertical fillwrap pf-col
87
    (list
Dave Griffiths's avatar
Dave Griffiths committed
88
     (build-grid-selector "pf-scan-nearest" "single" "<b>Nearest Neighbour Scan</b>: Closest Mongoose")
89
     (build-grid-selector "pf-scan-close" "toggle" "Mongooses within 2m")
90 91
     (mbutton "pf-scan-done" "Done"
              (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
92
                (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
Dave Griffiths's avatar
Dave Griffiths committed
93
                (entity-record-values!)
94
                (list (replace-fragment (get-id "pf-top") "pf-timer"))))))
95 96 97 98

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
99
     (entity-init! db "stream" "pup-focal-nearest" '())
Dave Griffiths's avatar
Dave Griffiths committed
100
     (entity-set-value! "scan-time" "varchar" (date-time->string (date-time)))
101
     (list
102 103
      (play-sound "ping")
      (vibrate 300)
104
      (populate-grid-selector
105
       "pf-scan-nearest" "single"
106
       (db-mongooses-by-pack-adults) #t
107
       (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
108
         (entity-set-value! "id-nearest" "varchar" (ktv-get individual "unique_id"))
109 110
         (list)))
      (populate-grid-selector
111
       "pf-scan-close" "toggle"
112
       (db-mongooses-by-pack-adults) #t
113
       (lambda (individuals)
Dave Griffiths's avatar
Dave Griffiths committed
114
         (entity-set-value! "id-list-close" "varchar" (assemble-array individuals))
115 116
         (list)))
      ))
117 118 119 120 121 122
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


123 124 125
  (fragment
   "ev-pupfeed"
   (linear-layout
126
    (make-id "") 'vertical fillwrap pf-col
127
    (list
128
     (mtitle "title" "Event: Pup is fed")
129
     (build-grid-selector "pf-pupfeed-who" "single" "Who fed the pup?")
Dave Griffiths's avatar
Dave Griffiths committed
130
     (spacer 20)
131
     (horiz
Dave Griffiths's avatar
Dave Griffiths committed
132
      (mtext "text" "Food size")
133 134 135
      (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
136 137
     (spacer 20)
     (horiz
138 139
      (mbutton "pf-pupfeed-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
140
                 (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
Dave Griffiths's avatar
Dave Griffiths committed
141
                 (entity-record-values!)
142 143 144
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-pupfeed-cancel" "Cancel"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
145
                 (list (replace-fragment (get-id "event-holder") "events")))))))
146 147 148 149

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
150
     (entity-init!  db "stream" "pup-focal-pupfeed" '())
151 152 153
     (list
      (populate-grid-selector
       "pf-pupfeed-who" "single"
154
       (db-mongooses-by-pack-adults) #t
155
       (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
156
         (entity-set-value! "id-who" "varchar" (ktv-get individual "unique_id"))
157 158 159 160 161 162 163
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

Dave Griffiths's avatar
Dave Griffiths committed
164 165 166
  (fragment
   "ev-pupfind"
   (linear-layout
167
    (make-id "") 'vertical fillwrap pf-col
Dave Griffiths's avatar
Dave Griffiths committed
168
    (list
169
     (mtitle "title" "Event: Pup found food")
Dave Griffiths's avatar
Dave Griffiths committed
170 171
     (horiz
      (mtext "text" "Food size")
172 173
      (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
174
     (spacer 20)
Dave Griffiths's avatar
Dave Griffiths committed
175
     (horiz
176 177
      (mbutton "pf-pupfind-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
178
                 (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
Dave Griffiths's avatar
Dave Griffiths committed
179
                 (entity-record-values!)
180 181 182
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-pupfind-cancel" "Cancel"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
183
                 (list (replace-fragment (get-id "event-holder") "events")))))))
Dave Griffiths's avatar
Dave Griffiths committed
184 185 186 187

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
188
     (entity-init! db "stream" "pup-focal-pupfind" '())
Dave Griffiths's avatar
Dave Griffiths committed
189 190 191 192 193 194 195 196 197 198 199
     (list
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


  (fragment
   "ev-pupcare"
   (linear-layout
200
    (make-id "") 'vertical fillwrap pf-col
Dave Griffiths's avatar
Dave Griffiths committed
201
    (list
202
     (mtitle "title" "Event: Pup is cared for")
Dave Griffiths's avatar
Dave Griffiths committed
203
     (build-grid-selector "pf-pupcare-who" "single" "Who cared for the pup?")
Dave Griffiths's avatar
Dave Griffiths committed
204
     (spacer 20)
Dave Griffiths's avatar
Dave Griffiths committed
205
     (horiz
Dave Griffiths's avatar
Dave Griffiths committed
206
      (mtext "text" "Type of care")
207
      (mspinner "pf-pupcare-type" list-pupcare-type
208
               (lambda (v)
209
                 (entity-set-value! "type" "varchar" (spinner-choice list-pupcare-type v)) '())))
Dave Griffiths's avatar
Dave Griffiths committed
210 211
     (spacer 20)
     (horiz
212 213
      (mbutton "pf-pupcare-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
214
                 (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
Dave Griffiths's avatar
Dave Griffiths committed
215
                 (entity-record-values!)
216 217 218
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-pupcare-cancel" "Cancel"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
219
                 (list (replace-fragment (get-id "event-holder") "events")))))))
Dave Griffiths's avatar
Dave Griffiths committed
220 221 222 223

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
224
     (entity-init! db "stream" "pup-focal-pupcare" '())
Dave Griffiths's avatar
Dave Griffiths committed
225 226 227
     (list
      (populate-grid-selector
       "pf-pupcare-who" "single"
228
       (db-mongooses-by-pack-adults) #t
Dave Griffiths's avatar
Dave Griffiths committed
229
       (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
230
         (entity-set-value! "id-who" "varchar" (ktv-get individual "unique_id"))
Dave Griffiths's avatar
Dave Griffiths committed
231 232 233 234 235 236 237 238 239 240
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "ev-pupaggr"
   (linear-layout
241
    (make-id "") 'vertical fillwrap pf-col
Dave Griffiths's avatar
Dave Griffiths committed
242
    (list
243
     (mtitle "title" "Event: Pup aggression")
Dave Griffiths's avatar
Dave Griffiths committed
244 245 246
     (build-grid-selector "pf-pupaggr-partner" "single" "Aggressive mongoose")

     (linear-layout
247
      (make-id "") 'horizontal (layout 'fill-parent 100 '1 'left 0) trans-col
Dave Griffiths's avatar
Dave Griffiths committed
248 249 250
      (list
       (vert
        (mtext "" "Fighting over")
251 252 253
        (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
254 255
       (vert
        (mtext "" "Level")
256 257 258
        (mspinner "pf-pupaggr-level" list-aggression-level
                  (lambda (v)
                    (entity-set-value! "level" "varchar" (spinner-choice list-aggression-level v)) '())))
259 260 261 262 263

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

       ;(mtoggle-button "pf-pupaggr-in" "Initiate?"
       ;                (lambda (v)
Dave Griffiths's avatar
Dave Griffiths committed
264
       ;                  (entity-set-value! "initiate" "varchar" (if v "yes" "no")) '()))
265 266 267 268


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

Dave Griffiths's avatar
Dave Griffiths committed
269
     (spacer 20)
270 271 272
     (horiz
      (mbutton "pf-pupaggr-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
273
                 (entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
Dave Griffiths's avatar
Dave Griffiths committed
274
                 (entity-record-values!)
275 276 277 278 279
                 (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
280 281 282 283

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
284
     (entity-init! db "stream" "pup-focal-pupaggr" '())
Dave Griffiths's avatar
Dave Griffiths committed
285 286 287
     (list
      (populate-grid-selector
       "pf-pupaggr-partner" "single"
288
       (db-mongooses-by-pack) #t
Dave Griffiths's avatar
Dave Griffiths committed
289
       (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
290
         (entity-set-value! "id-with" "varchar" (ktv-get individual "unique_id"))
Dave Griffiths's avatar
Dave Griffiths committed
291 292 293 294 295 296 297
         (list)))
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

298 299 300 301 302 303 304
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (fragment
   "ev-grpint"
   (linear-layout
    (make-id "") 'vertical fillwrap gp-col
    (list
305 306 307 308 309
     (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
310
        (mtext "text" "Outcome")
311 312 313
        (mspinner "gp-int-out" list-interaction-outcome
                  (lambda (v)
                    (entity-set-value! "outcome" "varchar" (spinner-choice list-interaction-outcome v)) '()))
314
        (mtext "text" "Duration")
315
        (edit-text (make-id "gp-int-dur") "" 30 "numeric" fillwrap
Dave Griffiths's avatar
Dave Griffiths committed
316
                   (lambda (v) (entity-set-value! "duration" "int" (string->number v)) '()))))
317 318 319 320
      (build-grid-selector "gp-int-pack" "single" "Other pack"))
     (linear-layout
      (make-id "") 'horizontal (layout 'fill-parent 80 '1 'left 0) trans-col
      (list
321 322
       (mbutton "pf-grpint-done" "Done"
                (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
323
                  (entity-record-values!)
324 325 326
                  (list (replace-fragment (get-id "event-holder") "events"))))
       (mbutton "pf-grpint-cancel" "Cancel"
                (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
327
                  (list (replace-fragment (get-id "event-holder") "events"))))))))
328

329

330 331 332
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
333
     (entity-init! db "stream" "group-interaction" '())
334 335 336 337 338
     (append
      (force-pause)
      (list
       (populate-grid-selector
        "gp-int-pack" "single"
339
        (db-all-sort-normal db "sync" "pack") #f
340
        (lambda (pack)
Dave Griffiths's avatar
Dave Griffiths committed
341
          (entity-set-value! "id-other-pack" "varchar" (ktv-get pack "unique_id"))
342 343 344
          (list)))
       (populate-grid-selector
        "gp-int-leader" "single"
345
        (db-mongooses-by-pack) #t
346
        (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
347
          (entity-set-value! "id-leader" "varchar" (ktv-get individual "unique_id"))
348 349
          (list)))
       )))
350 351 352 353 354 355 356 357 358 359 360 361 362
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


  (fragment
   "ev-grpalarm"
   (linear-layout
    (make-id "") 'vertical fillwrap gp-col
    (list
     (mtitle "title" "Event: Group alarm")
     (build-grid-selector "gp-alarm-caller" "single" "Alarm caller")
363 364 365 366 367 368

     (linear-layout
      (make-id "") 'horizontal fillwrap trans-col
      (list
       (vert
        (mtext "text" "Cause")
369 370 371
        (mspinner "gp-alarm-cause" list-alarm-cause
                  (lambda (v)
                    (entity-set-value! "cause" "varchar" (spinner-choice list-alarm-cause v)) '())))
372 373 374

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

375 376 377
     (horiz
      (mbutton "pf-grpalarm-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
378
                 (entity-record-values!)
379 380 381 382
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-grpalarm-cancel" "Cancel"
               (lambda ()
                 (list (replace-fragment (get-id "event-holder") "events")))))))
383 384 385 386

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
387
     (entity-init! db "stream" "group-alarm" '())
388 389 390 391 392
     (append
      (force-pause)
      (list
       (populate-grid-selector
        "gp-alarm-caller" "single"
393
        (db-mongooses-by-pack) #t
394
        (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
395
          (entity-set-value! "id-caller" "varchar" (ktv-get individual "unique_id"))
396
          (list))))
397 398 399 400 401 402 403 404 405 406 407
      ))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "ev-grpmov"
   (linear-layout
    (make-id "") 'vertical fillwrap gp-col
    (list
Dave Griffiths's avatar
Dave Griffiths committed
408
     (build-grid-selector "gp-mov-leader" "single" "<b>Group movement</b>: Leader")
409
     (linear-layout
410
      (make-id "") 'horizontal (layout 'fill-parent 'wrap-content '1 'left 0) trans-col
411
      (list
Dave Griffiths's avatar
Dave Griffiths committed
412
       (medit-text "gp-mov-w" "Pack width" "numeric"
Dave Griffiths's avatar
Dave Griffiths committed
413
                   (lambda (v) (entity-set-value! "pack-width" "int" (string->number v)) '()))
Dave Griffiths's avatar
Dave Griffiths committed
414
       (medit-text "gp-mov-l" "Pack depth" "numeric"
Dave Griffiths's avatar
Dave Griffiths committed
415
                   (lambda (v) (entity-set-value! "pack-depth" "int" (string->number v)) '()))
Dave Griffiths's avatar
Dave Griffiths committed
416
       (medit-text "gp-mov-c" "How many?" "numeric"
Dave Griffiths's avatar
Dave Griffiths committed
417
                   (lambda (v) (entity-set-value! "pack-count" "int" (string->number v)) '()))))
418
     (linear-layout
419
      (make-id "") 'horizontal (layout 'fill-parent 'wrap-content '1 'left 0) trans-col
420
      (list
421 422
       (vert
        (mtext "" "Direction")
423 424
        (mspinner "gp-mov-dir" list-move-direction
                  (lambda (v) (entity-set-value! "direction" "varchar" (spinner-choice list-move-direction v))  '())))
425

Dave Griffiths's avatar
Dave Griffiths committed
426 427
       (vert
        (mtext "" "Where to")
428 429
        (mspinner "gp-mov-to" list-move-to
                  (lambda (v) (entity-set-value! "destination" "varchar" (spinner-choice list-move-to v))  '())))))
Dave Griffiths's avatar
Dave Griffiths committed
430 431 432 433 434

     (spacer 20)
     (horiz
      (mbutton "pf-grpmov-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
435
                 (entity-record-values!)
Dave Griffiths's avatar
Dave Griffiths committed
436 437 438 439
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "pf-grpalarm-cancel" "Cancel"
               (lambda ()
                 (list (replace-fragment (get-id "event-holder") "events")))))))
440 441 442 443

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
444
     (entity-init! db "stream" "group-move" '())
445 446 447 448 449
     (append
      (force-pause)
      (list
       (populate-grid-selector
        "gp-mov-leader" "single"
450
        (db-mongooses-by-pack) #t
451
        (lambda (individual)
Dave Griffiths's avatar
Dave Griffiths committed
452
          (entity-set-value! "id-leader" "varchar" (ktv-get individual "unique_id"))
453 454
          (list)))
       )))
455 456 457 458 459
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

460 461 462 463 464 465
  (fragment
   "note"
   (linear-layout
    (make-id "") 'vertical fillwrap gp-col
    (list
     (mtitle "title" "Make a note")
466
     (edit-text (make-id "note-text") "" 30 "text" fillwrap
467
                (lambda (v)
Dave Griffiths's avatar
Dave Griffiths committed
468
                  (entity-set-value! "text" "varchar" v)
469 470 471 472
                  '()))
     (horiz
      (mbutton "note-done" "Done"
               (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
473
                 (entity-record-values!)
474 475 476 477 478 479 480
                 (list (replace-fragment (get-id "event-holder") "events"))))
      (mbutton "note-cancel" "Cancel"
               (lambda ()
                 (list (replace-fragment (get-id "event-holder") "events")))))))

   (lambda (fragment arg)
     (activity-layout fragment))
481
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
482
     (entity-init!  db "stream" "note" '())
483 484 485 486
     (append
      (force-pause)
      (list
       (update-widget 'edit-text (get-id "note-text") 'request-focus 1))))
487 488 489 490
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))
491 492 493 494


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

495

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

Dave Griffiths's avatar
Dave Griffiths committed
498
  (fragment
499
   "gc-start"
500
   (linear-layout
501
    (make-id "") 'vertical fill gc-col
502 503
    (list
     (mtitle "title" "Start")
504 505 506 507 508 509 510
     (horiz
      (mtoggle-button "gc-start-main-obs" "I'm the main observer"
                      (lambda (v) (entity-set-value! "main-observer" "varchar" v) '()))
      (vert
       (mtext "" "Code")
       (edit-text (make-id "gc-start-code") "" 30 "numeric" fillwrap
                  (lambda (v) (entity-set-value! "group-comp-code" "varchar" v) '()))))
Dave Griffiths's avatar
Dave Griffiths committed
511
     (build-grid-selector "gc-start-present" "toggle" "Who's present?")
Dave Griffiths's avatar
Dave Griffiths committed
512
     (next-button "gc-start-" "Go to weighing, have you finished here?" "gc-start" "gc-weights"
513
                  (lambda ()
Dave Griffiths's avatar
Dave Griffiths committed
514
                    (set-current! 'gc-not-present (dbg (invert-mongoose-selection (string-split-simple (entity-get-value "present") #\,))))
515 516
                    (entity-update-values!)
                    '()))
Dave Griffiths's avatar
Dave Griffiths committed
517
     ))
518 519 520 521

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
522 523 524
     ;; in case we come back from weights...
     (entity-init! db "stream" "group-composition"
                   (get-entity-by-unique db "stream" (get-current 'group-composition-id #f)))
Dave Griffiths's avatar
Dave Griffiths committed
525

526 527 528 529 530 531 532 533
     (append
      (list
       (populate-grid-selector
        "gc-start-present" "toggle"
        (db-mongooses-by-pack) #f
        (lambda (individuals)
          (entity-set-value! "present" "varchar" (assemble-array individuals))
          (list))
Dave Griffiths's avatar
Dave Griffiths committed
534
        (get-current 'gc-not-present '())))
535
      (update-grid-selector-checked "gc-start-present" "present"))
536
     )
537 538 539 540 541 542 543 544
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "gc-weights"
   (linear-layout
545
    (make-id "") 'vertical fill gc-col
546 547
    (list
     (mtitle "title" "Weights")
Dave Griffiths's avatar
Dave Griffiths committed
548
     (build-grid-selector "gc-weigh-choose" "single" "Choose mongoose")
Dave Griffiths's avatar
Dave Griffiths committed
549 550 551 552 553 554 555 556 557 558
     (spacer 20)
     (horiz
      (edit-text (make-id "gc-weigh-weight") "" 30 "numeric" fillwrap
                 (lambda (v)
                   (entity-update-single-value! (ktv "weight" "real" (string->number v)))
                   '()))
      (mtoggle-button "gc-weigh-accurate" "Accurate?"
                      (lambda (v)
                        (entity-update-single-value! (ktv "accurate" "int" (if v 1 0)))
                        '())))
Dave Griffiths's avatar
Dave Griffiths committed
559
     (next-button "gc-weigh-" "Go to pregnancies, have you finished here?" "gc-start" "gc-preg"
560 561 562 563 564
                  (lambda ()
                    ;; reset main entity
                    (entity-init! db "stream" "group-composition"
                                  (get-entity-by-unique db "stream" (get-current 'group-composition-id #f)))
                    '()))))
565 566 567 568

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
569
     (entity-init! db "stream" "weight" '())
570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596
     (append
      (list
       (populate-grid-selector
        "gc-weigh-choose" "single"
        (db-mongooses-by-pack) #f
        (lambda (individual)
          ;; search for a weight for this individual...
          (let ((s (db-filter
                    db "stream" "weight"
                    (list (list "parent" "varchar" "=" (get-current 'group-composition-id 0))
                          (list "id-mongoose" "varchar" "=" (ktv-get individual "unique_id"))))))
            (if (null? s)
                ;; not there, make a new one
                (entity-init&save! db "stream" "weight"
                                   (list
                                    (ktv "name" "varchar" "")
                                    (ktv "weight" "real" 0)
                                    (ktv "accurate" "int" 0)
                                    (ktv "parent" "varchar" (get-current 'group-composition-id 0))
                                    (ktv "id-mongoose" "varchar" (ktv-get individual "unique_id"))))
                (entity-init! db "stream" "weight" (car s)))
            (append
             (list
              (update-widget 'edit-text (get-id "gc-weigh-weight") 'text
                             (if (null? s) "" (ktv-get (car s) "weight")))
              (update-widget 'toggle-button (get-id "gc-weigh-accurate") 'selected
                             (if (null? s) 0 (ktv-get (car s) "accurate"))))
597
             (update-selector-colours "gc-weigh-choose" "weight" (list "weight" "real" "!=" 0)))))))
Dave Griffiths's avatar
Dave Griffiths committed
598
      (update-grid-selector-enabled "gc-weigh-choose" (get-current 'gc-not-present '()))
599
      (update-selector-colours "gc-weigh-choose" "weight" (list "weight" "real" "!=" 0))))
600 601 602 603 604 605 606 607
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "gc-preg"
   (linear-layout
608
    (make-id "") 'vertical fill gc-col
609 610
    (list
     (mtitle "title" "Pregnant females")
Dave Griffiths's avatar
Dave Griffiths committed
611
     (build-grid-selector "gc-preg-choose" "toggle" "Choose")
Dave Griffiths's avatar
Dave Griffiths committed
612
     (next-button "gc-preg-" "Going to pup associations, have you finished here?" "gc-weights" "gc-pup-assoc"
Dave Griffiths's avatar
Dave Griffiths committed
613
                  (lambda () '()))))
614 615 616 617

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
618 619 620 621 622 623 624 625 626
     (append
      (list
       (populate-grid-selector
        "gc-preg-choose" "toggle"
        (db-mongooses-by-pack-female) #f
        (lambda (individuals)
          (entity-update-single-value! (ktv "pregnant" "varchar" (assemble-array individuals)))
          (list)))
       )
Dave Griffiths's avatar
Dave Griffiths committed
627
      (update-grid-selector-enabled "gc-preg-choose" (get-current 'gc-not-present '()))
628
      (update-grid-selector-checked "gc-preg-choose" "pregnant")))
629 630 631 632 633
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

634

635 636 637
  (fragment
   "gc-pup-assoc"
   (linear-layout
638
    (make-id "") 'vertical fill gc-col
639
    (list
Dave Griffiths's avatar
Dave Griffiths committed
640
     (mtitle "title" "Pup Associations")
641
     (build-grid-selector "gc-pup-choose" "single" "Choose pup")
Dave Griffiths's avatar
Dave Griffiths committed
642 643 644
     (horiz
      (vert
       (mtext "" "Strength")
645 646
       (mspinner "gc-pup-strength" list-strength
                 (lambda (v)
Dave Griffiths's avatar
Dave Griffiths committed
647
                   (msg "updating stren" (spinner-choice list-strength v))
648 649
                   (entity-update-single-value! (ktv "strength" "varchar" (spinner-choice list-strength v)))
                   '())))
Dave Griffiths's avatar
Dave Griffiths committed
650 651
      (vert
       (mtext "" "Accuracy")
652 653 654 655 656
       (mspinner "gc-pup-accuracy" list-strength
                 (lambda (v)
                   (msg "updating acc")
                   (entity-update-single-value! (ktv "accurate" "varchar" (spinner-choice list-strength v)))
                   '()))))
Dave Griffiths's avatar
Dave Griffiths committed
657
     (build-grid-selector "gc-pup-escort" "toggle" "Escort")
Dave Griffiths's avatar
Dave Griffiths committed
658
     (next-button "gc-pup-assoc-" "Going to oestrus, have you finished here?" "gc-preg" "gc-oestrus"
Dave Griffiths's avatar
Dave Griffiths committed
659
                  (lambda () '()))))
660 661 662 663

   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
664 665 666
     (entity-init! db "stream" "pup-assoc" '())
     (append
      (list
667 668 669 670 671 672 673
       (populate-grid-selector
        "gc-pup-escort" "single"
        (db-mongooses-by-pack-adults) #t
        (lambda (escort-individual)
          ;; no pup yet...
          (list)))

674 675 676
       (populate-grid-selector
        "gc-pup-choose" "single"
        (db-mongooses-by-pack-pups) #f
677 678 679 680 681 682 683
        (lambda (pup-individual)
          (append
           (list
            (populate-grid-selector
             "gc-pup-escort" "single"
             (db-mongooses-by-pack-adults) #t
             (lambda (escort-individual)
Dave Griffiths's avatar
Dave Griffiths committed
684
               (msg "escort-individual clicked")
685 686 687 688 689 690 691 692 693 694 695
               (let ((s (db-filter
                         db "stream" "pup-assoc"
                         (list (list "parent" "varchar" "=" (get-current 'group-composition-id 0))
                               (list "id-escort" "varchar" "=" (ktv-get escort-individual "unique_id"))
                               (list "id-mongoose" "varchar" "=" (ktv-get pup-individual "unique_id"))))))
                 (if (null? s)
                     ;; not there, make a new one
                     (entity-init&save! db "stream" "pup-assoc"
                                        (list
                                         (ktv "name" "varchar" "")
                                         (ktv "id-escort" "varchar" (ktv-get escort-individual "unique_id"))
Dave Griffiths's avatar
Dave Griffiths committed
696 697
                                         (ktv "accurate" "varchar" "none")
                                         (ktv "strength" "varchar" "none")
698 699 700 701 702 703 704 705
                                         (ktv "parent" "varchar" (get-current 'group-composition-id 0))
                                         (ktv "id-mongoose" "varchar" (ktv-get pup-individual "unique_id"))))
                     (entity-init! db "stream" "pup-assoc" (car s)))
                 (append
                  (list
                   (update-widget 'spinner (get-id "gc-pup-strength") 'selection (spinner-index list-strength (entity-get-value "strength")))
                   (update-widget 'spinner (get-id "gc-pup-accuracy") 'selection (spinner-index list-strength (entity-get-value "accurate"))))

Dave Griffiths's avatar
Dave Griffiths committed
706 707 708 709 710 711
                  (update-selector-colours2
                   "gc-pup-escort" "pup-assoc"
                   (list
                    (list "id-mongoose" "varchar" "=" (ktv-get pup-individual "unique_id"))
                    (list "strength" "varchar" "!=" "none")
                    (list "accurate" "varchar" "!=" "none"))))
712 713

                 ))))
Dave Griffiths's avatar
Dave Griffiths committed
714 715 716 717 718 719
           (update-selector-colours2
            "gc-pup-escort" "pup-assoc"
            (list
             (list "id-mongoose" "varchar" "=" (ktv-get pup-individual "unique_id"))
             (list "strength" "varchar" "!=" "none")
             (list "accurate" "varchar" "!=" "none")))
720
           (update-selector-colours3 "gc-pup-choose" "pup-assoc")
Dave Griffiths's avatar
Dave Griffiths committed
721
           (update-grid-selector-enabled "gc-pup-escort" (get-current 'gc-not-present '()))
722
           ))))
Dave Griffiths's avatar
Dave Griffiths committed
723 724
      (update-grid-selector-enabled "gc-pup-escort" (get-current 'gc-not-present '()))
      (update-grid-selector-enabled "gc-pup-choose" (get-current 'gc-not-present '()))
725 726
      (update-selector-colours3 "gc-pup-choose" "pup-assoc")
      ))
727

728 729 730 731 732
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

733 734


735 736 737
  (fragment
   "gc-oestrus"
   (linear-layout
738
    (make-id "") 'vertical fill gc-col
739
    (list
Dave Griffiths's avatar
Dave Griffiths committed
740
     (mtitle "" "Oestrus")
Dave Griffiths's avatar
Dave Griffiths committed
741 742 743 744
     (build-grid-selector "gc-oestrus-female" "single" "Choose female")
     (horiz
      (vert
       (mtext "" "Strength")
745
       (mspinner "gc-oestrus-strength" list-strength
Dave Griffiths's avatar
Dave Griffiths committed
746 747 748 749
                 (lambda (v)
                   (msg "updating stren" (spinner-choice list-strength v))
                   (entity-update-single-value! (ktv "strength" "varchar" (spinner-choice list-strength v)))
                   '())))
Dave Griffiths's avatar
Dave Griffiths committed
750 751
      (vert
       (mtext "" "Accuracy")
752
       (mspinner "gc-oestrus-accuracy" list-strength
Dave Griffiths's avatar
Dave Griffiths committed
753 754 755 756
                 (lambda (v)
                   (msg "updating acc")
                   (entity-update-single-value! (ktv "accurate" "varchar" (spinner-choice list-strength v)))
                   '()))))
757
     (build-grid-selector "gc-oestrus-guard" "toggle" "Choose mate guard")
Dave Griffiths's avatar
Dave Griffiths committed
758
     (next-button "gc-pup-oestrus-" "Going to babysitters, have you finished here?" "gc-pup-assoc" "gc-babysitting"
Dave Griffiths's avatar
Dave Griffiths committed
759
                  (lambda () '()))))
760 761 762
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
763 764 765
     (entity-init! db "stream" "mate-guard" '())
     (append
      (list
Dave Griffiths's avatar
Dave Griffiths committed
766 767 768 769 770 771 772
       (populate-grid-selector
        "gc-oestrus-guard" "single"
        (db-mongooses-by-pack-male) #t
        (lambda (escort-individual)
          ;; no pup yet...
          (list)))

773 774 775
       (populate-grid-selector
        "gc-oestrus-female" "single"
        (db-mongooses-by-pack-female) #f
Dave Griffiths's avatar
Dave Griffiths committed
776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793
        (lambda (pup-individual)
          (append
           (list
            (populate-grid-selector
             "gc-oestrus-guard" "single"
             (db-mongooses-by-pack-adults) #t
             (lambda (escort-individual)
               (let ((s (db-filter
                         db "stream" "mate-guard"
                         (list (list "parent" "varchar" "=" (get-current 'group-composition-id 0))
                               (list "id-escort" "varchar" "=" (ktv-get escort-individual "unique_id"))
                               (list "id-mongoose" "varchar" "=" (ktv-get pup-individual "unique_id"))))))
                 (if (null? s)
                     ;; not there, make a new one
                     (entity-init&save! db "stream" "mate-guard"
                                        (list
                                         (ktv "name" "varchar" "")
                                         (ktv "id-escort" "varchar" (ktv-get escort-individual "unique_id"))
Dave Griffiths's avatar
Dave Griffiths committed
794 795
                                         (ktv "accurate" "varchar" "none")
                                         (ktv "strength" "varchar" "none")
Dave Griffiths's avatar
Dave Griffiths committed
796 797 798 799 800 801 802 803
                                         (ktv "parent" "varchar" (get-current 'group-composition-id 0))
                                         (ktv "id-mongoose" "varchar" (ktv-get pup-individual "unique_id"))))
                     (entity-init! db "stream" "mate-guard" (car s)))
                 (append
                  (list
                   (update-widget 'spinner (get-id "gc-oestrus-strength") 'selection (spinner-index list-strength (entity-get-value "strength")))
                   (update-widget 'spinner (get-id "gc-oestrus-accuracy") 'selection (spinner-index list-strength (entity-get-value "accurate"))))

Dave Griffiths's avatar
Dave Griffiths committed
804 805 806 807 808 809
                  (update-selector-colours2
                   "gc-oestrus-guard" "mate-guard"
                   (list
                    (list "id-mongoose" "varchar" "=" (ktv-get pup-individual "unique_id"))
                    (list "strength" "varchar" "!=" "none")
                    (list "accurate" "varchar" "!=" "none"))))
Dave Griffiths's avatar
Dave Griffiths committed
810
                 ))))
Dave Griffiths's avatar
Dave Griffiths committed
811 812 813 814 815 816
           (update-selector-colours2
            "gc-oestrus-guard" "mate-guard"
            (list
             (list "id-mongoose" "varchar" "=" (ktv-get pup-individual "unique_id"))
             (list "strength" "varchar" "!=" "none")
             (list "accurate" "varchar" "!=" "none")))
Dave Griffiths's avatar
Dave Griffiths committed
817
           (update-selector-colours3 "gc-oestrus-female" "mate-guard")
Dave Griffiths's avatar
Dave Griffiths committed
818
           (update-grid-selector-enabled "gc-oestrus-guard" (get-current 'gc-not-present '()))
Dave Griffiths's avatar
Dave Griffiths committed
819
           ))))
Dave Griffiths's avatar
Dave Griffiths committed
820 821
      (update-grid-selector-enabled "gc-oestrus-guard" (get-current 'gc-not-present '()))
      (update-grid-selector-enabled "gc-oestrus-female" (get-current 'gc-not-present '()))
Dave Griffiths's avatar
Dave Griffiths committed
822 823
      (update-selector-colours3 "gc-oestrus-female" "mate-guard")
      ))
824

825 826 827 828 829 830 831 832
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

  (fragment
   "gc-babysitting"
   (linear-layout
833
    (make-id "") 'vertical fill gc-col
834
    (list
Dave Griffiths's avatar
Dave Griffiths committed
835
     (mtitle "" "Babysitters")
Dave Griffiths's avatar
Dave Griffiths committed
836 837 838 839
     (mtitle "title" "Seen")
     (build-grid-selector "gc-baby-seen" "toggle" "Choose")
     (mtitle "title" "By elimination")
     (build-grid-selector "gc-baby-byelim" "toggle" "Choose")
Dave Griffiths's avatar
Dave Griffiths committed
840
     (next-button "gc-pup-baby-" "Ending, have you finished here?" "gc-oestrus" "gc-end"
Dave Griffiths's avatar
Dave Griffiths committed
841
                  (lambda () '()))))
842 843 844
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
Dave Griffiths's avatar
Dave Griffiths committed
845 846 847 848 849 850 851 852 853
     (append
      (list
       (populate-grid-selector
        "gc-baby-seen" "toggle"
        (db-mongooses-by-pack-adults) #f
        (lambda (individuals)
          (entity-update-single-value! (ktv "baby-seen" "varchar" (assemble-array individuals)))
          (list)))
       )
Dave Griffiths's avatar
Dave Griffiths committed
854
      (update-grid-selector-enabled "gc-baby-seen" (get-current 'gc-not-present '()))
Dave Griffiths's avatar
Dave Griffiths committed
855 856 857 858 859 860 861 862 863
      (update-grid-selector-checked "gc-baby-seen" "baby-seen")
      (list
       (populate-grid-selector
        "gc-baby-byelim" "toggle"
        (db-mongooses-by-pack-adults) #f
        (lambda (individuals)
          (entity-update-single-value! (ktv "baby-byelim" "varchar" (assemble-array individuals)))
          (list)))
       )
Dave Griffiths's avatar
Dave Griffiths committed
864
      (update-grid-selector-enabled "gc-baby-byelim" (get-current 'gc-not-present '()))
Dave Griffiths's avatar
Dave Griffiths committed
865
      (update-grid-selector-checked "gc-baby-byelim" "baby-byelim")))
866 867 868 869
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))
870

871 872 873
  (fragment
   "gc-end"
   (linear-layout
874
    (make-id "") 'vertical fill gc-col
875
    (list
Dave Griffiths's avatar
Dave Griffiths committed
876
     (mtitle "" "Finish group composition")
Dave Griffiths's avatar
Dave Griffiths committed
877
     (next-button "gc-pup-baby-" "Ending, have you finished here?" "gc-babysitting" "gc-end"
Dave Griffiths's avatar
Dave Griffiths committed
878
                  (lambda () (list (finish-activity 0))))))
Dave Griffiths's avatar
Dave Griffiths committed
879 880
   (lambda (fragment arg)
     (activity-layout fragment))
881 882
   (lambda (fragment arg)
     (list))
Dave Griffiths's avatar
Dave Griffiths committed
883 884 885 886 887
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))

888 889


Dave Griffiths's avatar
Dave Griffiths committed
890 891
  )

892 893 894 895
(msg "one")

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

897
(define-activity-list
898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915
;  (activity
;   "splash"
;   (vert
;    (text-view (make-id "splash-title") "Mongoose 2000" 40 fillwrap)
;    (mtext "splash-about" "Advanced mongoose technology")
;    (spacer 20)
;    (mbutton2 "f2" "Get started!" (lambda () (list (start-activity-goto "main" 2 ""))))
;    )
;
;   (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