Commit 5cc16103 authored by Dave Griffiths's avatar Dave Griffiths
Browse files

fixed loads of group comp stuff

parent 2ed59d11
......@@ -713,7 +713,6 @@
(mbutton (string-append id "-nextb") "Next"
(lambda ()
(msg "update from next button")
(entity-update-values!)
(append
(fn)
......@@ -729,7 +728,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (update-selector-colours id entity-type where)
(msg "update-selector-colours")
(update-grid-selector-colours
id "id-mongoose"
(db-filter
......@@ -739,7 +737,6 @@
where))))
(define (update-selector-colours2 id entity-type where)
(msg "update-selector-colours 2")
(update-grid-selector-colours
id "id-escort"
(db-filter
......@@ -749,7 +746,6 @@
where))))
(define (update-selector-colours3 id entity-type)
(msg "update-selector-colours 3")
(update-grid-selector-colours
id "id-mongoose"
(db-filter
......@@ -758,10 +754,7 @@
(list "parent" "varchar" "=" (get-current 'group-composition-id 0))))))
(define (invert-mongoose-selection individuals)
(msg "invert-mongoose-selection")
(msg individuals)
(filter
(lambda (m)
(msg m)
(dbg (not (in-list? m individuals))))
(not (in-list? m individuals)))
(map (lambda (m) (ktv-get m "unique_id")) (db-mongooses-by-pack))))
......@@ -503,15 +503,17 @@
(mtitle "title" "Start")
(horiz
(mtoggle-button "gc-start-main-obs" "I'm the main observer"
(lambda (v) (entity-set-value! "main-observer" "varchar" v) '()))
(lambda (v) (entity-update-single-value!
(ktv "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) '()))))
(lambda (v) (entity-update-values!
(ktv "group-comp-code" "varchar" v)) '()))))
(build-grid-selector "gc-start-present" "toggle" "Who's present?")
(next-button "gc-start-" "Go to weighing, have you finished here?" "gc-start" "gc-weights"
(lambda ()
(set-current! 'gc-not-present (dbg (invert-mongoose-selection (string-split-simple (entity-get-value "present") #\,))))
(set-current! 'gc-not-present (invert-mongoose-selection (string-split-simple (entity-get-value "present") #\,)))
(entity-update-values!)
'()))
))
......@@ -520,6 +522,7 @@
(activity-layout fragment))
(lambda (fragment arg)
;; in case we come back from weights...
(msg "frag start:" (get-current 'group-composition-id #f))
(entity-init! db "stream" "group-composition"
(get-entity-by-unique db "stream" (get-current 'group-composition-id #f)))
......@@ -531,7 +534,9 @@
(lambda (individuals)
(entity-set-value! "present" "varchar" (assemble-array individuals))
(list))
(get-current 'gc-not-present '())))
;; need to invert, but not () if there are none set yet...
(let ((r (get-current 'gc-not-present #f)))
(if (not r) '() (invert-mongoose-selection r)))))
(update-grid-selector-checked "gc-start-present" "present"))
)
(lambda (fragment) '())
......@@ -592,7 +597,7 @@
(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
(update-widget 'toggle-button (get-id "gc-weigh-accurate") 'checked
(if (null? s) 0 (ktv-get (car s) "accurate"))))
(update-selector-colours "gc-weigh-choose" "weight" (list "weight" "real" "!=" 0)))))))
(update-grid-selector-enabled "gc-weigh-choose" (get-current 'gc-not-present '()))
......@@ -753,7 +758,14 @@
(lambda (v)
(msg "updating acc")
(entity-update-single-value! (ktv "accurate" "varchar" (spinner-choice list-strength v)))
'()))))
'())))
(mtoggle-button "gc-oestrus-pester" "Pestering?"
(lambda (v)
(entity-update-single-value! (ktv "pester" "int" (if v 1 0)))
'()))
)
(build-grid-selector "gc-oestrus-guard" "toggle" "Choose mate guard")
(next-button "gc-pup-oestrus-" "Going to babysitters, have you finished here?" "gc-pup-assoc" "gc-babysitting"
(lambda () '()))))
......@@ -793,13 +805,15 @@
(ktv "id-escort" "varchar" (ktv-get escort-individual "unique_id"))
(ktv "accurate" "varchar" "none")
(ktv "strength" "varchar" "none")
(ktv "pester" "int" 0)
(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"))))
(update-widget 'spinner (get-id "gc-oestrus-accuracy") 'selection (spinner-index list-strength (entity-get-value "accurate")))
(update-widget 'toggle-button (get-id "gc-oestrus-pester") 'checked (entity-get-value "pester")))
(update-selector-colours2
"gc-oestrus-guard" "mate-guard"
......@@ -875,7 +889,11 @@
(list
(mtitle "" "Finish group composition")
(next-button "gc-pup-baby-" "Ending, have you finished here?" "gc-babysitting" "gc-end"
(lambda () (list (finish-activity 0))))))
(lambda ()
;; clean up...
(get-current 'gc-not-present '())
(set-current! 'group-composition-id #f)
(list (finish-activity 0))))))
(lambda (fragment arg)
(activity-layout fragment))
(lambda (fragment arg)
......@@ -1012,13 +1030,18 @@
((eq? (get-current 'observation "none") obs-gp)
(list (start-activity "group-events" 2 "")))
(else
;; create a new gc entity
;; initialise it to the current memory entity
(set-current!
'group-composition-id
(entity-init&save!
db "stream" "group-composition"
(list (ktv "pack" "varchar" (ktv-get (get-current 'pack ()) "unique_id")))))
;; check if there is currently a gc activity active
(msg "gc id = " (get-current 'group-composition-id #f))
(when (not (get-current 'group-composition-id #f))
(msg "making new gc")
;; create a new gc entity
;; initialise it to the current memory entity
(set-current!
'group-composition-id
(entity-init&save!
db "stream" "group-composition"
(list (ktv "pack" "varchar" (ktv-get (get-current 'pack ()) "unique_id"))))))
(list
(start-activity "group-composition" 2 ""))))
(list
......@@ -1035,7 +1058,13 @@
"choose-obs-pack-selector" "single"
(db-all-sort-normal db "sync" "pack") #f
(lambda (pack)
(msg "in selector" pack)
(when (and
(get-current 'pack #f) ;; if we have a current pack...
(not (equal? (ktv-get pack "unique_id")
(ktv-get (get-current 'pack '()) "unique_id"))))
;; need to clear the current group comp
;; id here if we are changing the pack
(set-current! 'group-composition-id #f))
(set-current! 'pack pack)
'()))))
(lambda (activity) '())
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment