Commit 92c5d1b7 authored by Dave Griffiths's avatar Dave Griffiths
Browse files

load/save from fragment

parent f8f00988
...@@ -308,6 +308,26 @@ ...@@ -308,6 +308,26 @@
(cdr s))))) (cdr s)))))
(define (update-entities-where2 db table type ktv ktv2)
(let ((s (db-select
db (string-append
"select e.entity_id from " table "_entity as e "
"join " table "_value_" (ktv-type ktv)
" as a on a.entity_id = e.entity_id "
"join " table "_value_" (ktv-type ktv2)
" as b on b.entity_id = e.entity_id "
"where e.entity_type = ? and a.attribute_id = ? and b.attribute_id =? and a.value = ? and b.value = ? ")
type (ktv-key ktv) (ktv-key ktv2) (ktv-value ktv) (ktv-value ktv2))))
(msg (db-status db))
(if (null? s)
'()
(map
(lambda (i)
(vector-ref i 0))
(cdr s)))))
(define (validate db) (define (validate db)
;; check attribute for duplicate entity-id/attribute-ids ;; check attribute for duplicate entity-id/attribute-ids
0) 0)
......
...@@ -153,7 +153,6 @@ ...@@ -153,7 +153,6 @@
(entity-add-value! "lat" "real" 0) (entity-add-value! "lat" "real" 0)
(entity-add-value! "lon" "real" 0) (entity-add-value! "lon" "real" 0)
(let ((values (get-current 'entity-values '()))) (let ((values (get-current 'entity-values '())))
(msg values)
(cond (cond
((not (null? values)) ((not (null? values))
(let ((r (insert-entity/get-unique (let ((r (insert-entity/get-unique
...@@ -223,7 +222,6 @@ ...@@ -223,7 +222,6 @@
(string-append "req-" (list-ref (car e) 1)) (string-append "req-" (list-ref (car e) 1))
(build-url-from-entity table e) (build-url-from-entity table e)
(lambda (v) (lambda (v)
(msg "spat" e v)
(cond (cond
((or (equal? (car v) "inserted") (equal? (car v) "match")) ((or (equal? (car v) "inserted") (equal? (car v) "match"))
(update-entity-clean db table (cadr v)) (update-entity-clean db table (cadr v))
...@@ -249,7 +247,6 @@ ...@@ -249,7 +247,6 @@
(string-append unique-id "-update-new") (string-append unique-id "-update-new")
(string-append url "fn=entity&table=" table "&unique-id=" unique-id) (string-append url "fn=entity&table=" table "&unique-id=" unique-id)
(lambda (data) (lambda (data)
(msg "data from server request" data)
;; check "sync-insert" in sync.ss raspberry pi-side for the contents of 'entity' ;; check "sync-insert" in sync.ss raspberry pi-side for the contents of 'entity'
(let ((entity (list-ref data 0)) (let ((entity (list-ref data 0))
(ktvlist (list-ref data 1))) (ktvlist (list-ref data 1)))
...@@ -311,7 +308,6 @@ ...@@ -311,7 +308,6 @@
(define (build-dirty) (define (build-dirty)
(let ((sync (get-dirty-stats db "sync")) (let ((sync (get-dirty-stats db "sync"))
(stream (get-dirty-stats db "stream"))) (stream (get-dirty-stats db "stream")))
(msg sync stream)
(string-append (string-append
"Pack data: " (number->string (car sync)) "/" (number->string (cadr sync)) " " "Pack data: " (number->string (car sync)) "/" (number->string (cadr sync)) " "
"Focal data: " (number->string (car stream)) "/" (number->string (cadr stream))))) "Focal data: " (number->string (car stream)) "/" (number->string (cadr stream)))))
...@@ -462,7 +458,7 @@ ...@@ -462,7 +458,7 @@
(cadr (findv v id->items))) (cadr (findv v id->items)))
selected-set))) selected-set)))
(else (else
(msg (findv v id->items)) ;;(msg (findv v id->items))
(fn (cadr (findv v id->items)))))))))) (fn (cadr (findv v id->items))))))))))
(prof-end "popgrid") (prof-end "popgrid")
r))) r)))
...@@ -548,6 +544,22 @@ ...@@ -548,6 +544,22 @@
(string-append (number->string (get-current 'timer-seconds 59)))) (string-append (number->string (get-current 'timer-seconds 59))))
))) )))
(define (next-button id dialog-msg next-frag fn)
(mbutton (string-append id "-nextb") "Next"
(lambda ()
(list
(alert-dialog
(string-append id "-d")
dialog-msg
(lambda (v)
(cond
((eqv? v 1)
(append
(fn) (list (replace-fragment
(get-id "gc-top") next-frag))))
(else '()))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; fragments ;; fragments
...@@ -995,7 +1007,7 @@ ...@@ -995,7 +1007,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;(replace-fragment (get-id "gc-top") (cadr frag))))))))
(fragment (fragment
"gc-start" "gc-start"
...@@ -1003,19 +1015,30 @@ ...@@ -1003,19 +1015,30 @@
(make-id "") 'vertical fill gc-col (make-id "") 'vertical fill gc-col
(list (list
(mtitle "title" "Start") (mtitle "title" "Start")
(mtoggle-button "gc-start-main-obs" "Main observer" (lambda (v) '())) (mtoggle-button "gc-start-main-obs" "Main observer"
(lambda (v) (entity-add-value! "main-observer" "varchar" v) '()))
(mtext "" "Code") (mtext "" "Code")
(edit-text (make-id "gc-start-code") "" 20 "numeric" fillwrap (lambda (v) '())) (edit-text (make-id "gc-start-code") "" 20 "numeric" fillwrap
(build-grid-selector "gc-start-present" "toggle" "Who's present?"))) (lambda (v) (entity-add-value! "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-weights"
(lambda () '()))
))
(lambda (fragment arg) (lambda (fragment arg)
(activity-layout fragment)) (activity-layout fragment))
(lambda (fragment arg) (lambda (fragment arg)
(set-current! 'group-composition-id (entity-record-values db "stream" "group-composition"))
(entity-add-value!
(list (list
(populate-grid-selector (populate-grid-selector
"gc-start-present" "toggle" "gc-start-present" "toggle"
(db-mongooses-by-pack) (db-mongooses-by-pack)
(lambda (individual) (lambda (individual)
(lambda (v) (entity-add-value! "group-comp-code" "varchar" v) '()))
(list))) (list)))
)) ))
(lambda (fragment) '()) (lambda (fragment) '())
...@@ -1029,19 +1052,51 @@ ...@@ -1029,19 +1052,51 @@
(make-id "") 'vertical fill gc-col (make-id "") 'vertical fill gc-col
(list (list
(mtitle "title" "Weights") (mtitle "title" "Weights")
(build-grid-selector "gc-weigh-choose" "toggle" "Choose mongoose") (build-grid-selector "gc-weigh-choose" "single" "Choose mongoose")
(edit-text (make-id "gc-weigh-weight") "" 20 "numeric" fillwrap (lambda (v) '())) (horiz
(mtoggle-button "gc-weigh-accurate" "Accurate?" (lambda (v) '())))) (edit-text (make-id "gc-weigh-weight") "" 20 "numeric" fillwrap
(lambda (v)
(entity-add-value! "weight" "varchar" v)
'()))
(mbutton "gc-weigh-save" "Save"
(lambda ()
(msg "saving")
(entity-add-value! "parent" "varchar" (get-current 'group-composition-id 0))
(msg "saving to " (get-current 'entity-id "0"))
(if (get-current 'updating #f)
(entity-update-values db "stream")
(entity-record-values db "stream" "weight")
(entity-reset!)
'()))))
(mtoggle-button "gc-weigh-accurate" "Accurate?" (lambda (v) '()))
(next-button "gc-weigh-" "Go to pregnancies, have you finished here?" "gc-preg"
(lambda () '()))))
(lambda (fragment arg) (lambda (fragment arg)
(activity-layout fragment)) (activity-layout fragment))
(lambda (fragment arg) (lambda (fragment arg)
(entity-reset!)
(list (list
(populate-grid-selector (populate-grid-selector
"gc-weigh-choose" "toggle" "gc-weigh-choose" "single"
(db-mongooses-by-pack) (db-mongooses-by-pack)
(lambda (individual) (lambda (individual)
(list))) (msg "loading")
(entity-add-value! "id-mongoose" "varchar" (ktv-get individual "unique_id"))
(set-current! 'updating #f)
(let ((s (db-all-where2
db "stream" "weight"
(ktv "parent" "varchar" (get-current 'group-composition-id 0))
(ktv "id-mongoose" "varchar" (ktv-get individual "unique_id")))))
(when (not (null? s))
(msg "found previous")
(entity-add-value! "unique_id" "varchar" (ktv-get (car s) "unique_id"))
(set-current! 'updating #t))
(msg "-->" s)
(list
(update-widget 'edit-text (get-id "gc-weigh-weight") 'text
(if (null? s) "" (ktv-get (car s) "weight")))))))
)) ))
(lambda (fragment) '()) (lambda (fragment) '())
(lambda (fragment) '()) (lambda (fragment) '())
...@@ -1054,7 +1109,9 @@ ...@@ -1054,7 +1109,9 @@
(make-id "") 'vertical fill gc-col (make-id "") 'vertical fill gc-col
(list (list
(mtitle "title" "Pregnant females") (mtitle "title" "Pregnant females")
(build-grid-selector "gc-preg-choose" "toggle" "Choose"))) (build-grid-selector "gc-preg-choose" "toggle" "Choose")
(next-button "gc-preg-" "Going to pup associations, have you finished here?" "gc-pup-assoc"
(lambda () '()))))
(lambda (fragment arg) (lambda (fragment arg)
(activity-layout fragment)) (activity-layout fragment))
...@@ -1077,21 +1134,30 @@ ...@@ -1077,21 +1134,30 @@
(linear-layout (linear-layout
(make-id "") 'vertical fill gc-col (make-id "") 'vertical fill gc-col
(list (list
(mtitle "title" "Pup Associations") (mtext "title" "Pup Associations")
(build-grid-selector "gc-pup-choose" "toggle" "Choose pup") (build-grid-selector "gc-pup-choose" "toggle" "Choose pup")
(build-grid-selector "gc-pup-escort" "toggle" "Escort"))) (horiz
(vert
(mtext "" "Strength")
(spinner (make-id "gc-pup-strength") (list "Weak" "Medium" "Strong") fillwrap
(lambda (v) '())))
(vert
(mtext "" "Accuracy")
(spinner (make-id "gc-pup-accuracy") (list "Weak" "Medium" "Strong") fillwrap
(lambda (v) '()))))
(build-grid-selector "gc-pup-escort" "toggle" "Escort")
(next-button "gc-pup-assoc-" "Going to oestrus, have you finished here?" "gc-oestrus"
(lambda () '()))))
(lambda (fragment arg) (lambda (fragment arg)
(activity-layout fragment)) (activity-layout fragment))
(lambda (fragment arg) (lambda (fragment arg)
(list (list
(populate-grid-selector (populate-grid-selector "gc-pup-choose" "toggle"
"gc-pup-choose" "toggle"
(db-mongooses-by-pack-pups) (db-mongooses-by-pack-pups)
(lambda (individual) (lambda (individual)
(list))) (list)))
(populate-grid-selector (populate-grid-selector "gc-pup-escort" "toggle"
"gc-pup-escort" "toggle"
(db-mongooses-by-pack-adults) (db-mongooses-by-pack-adults)
(lambda (individual) (lambda (individual)
(list))) (list)))
...@@ -1106,11 +1172,34 @@ ...@@ -1106,11 +1172,34 @@
(linear-layout (linear-layout
(make-id "") 'vertical fill gc-col (make-id "") 'vertical fill gc-col
(list (list
(mtext "" "Oestrus..."))) (mtext "" "Oestrus")
(build-grid-selector "gc-oestrus-female" "single" "Choose female")
(horiz
(vert
(mtext "" "Strength")
(spinner (make-id "gc-oestrus-strength") (list "Weak" "Medium" "Strong") fillwrap
(lambda (v) '())))
(vert
(mtext "" "Accuracy")
(spinner (make-id "gc-oestrus-accuracy") (list "Weak" "Medium" "Strong") fillwrap
(lambda (v) '()))))
(build-grid-selector "gc-oestrus-guard" "single" "Choose mate guard")
(next-button "gc-pup-oestrus-" "Going to babysitters, have you finished here?" "gc-babysitting"
(lambda () '()))))
(lambda (fragment arg) (lambda (fragment arg)
(activity-layout fragment)) (activity-layout fragment))
(lambda (fragment arg) (lambda (fragment arg)
(list)) (list
(populate-grid-selector
"gc-oestrus-female" "single"
(db-mongooses-by-pack-female)
(lambda (individual)
(list)))
(populate-grid-selector
"gc-oestrus-guard" "single"
(db-mongooses-by-pack-male)
(lambda (individual)
))))
(lambda (fragment) '()) (lambda (fragment) '())
(lambda (fragment) '()) (lambda (fragment) '())
(lambda (fragment) '()) (lambda (fragment) '())
...@@ -1121,7 +1210,9 @@ ...@@ -1121,7 +1210,9 @@
(linear-layout (linear-layout
(make-id "") 'vertical fill gc-col (make-id "") 'vertical fill gc-col
(list (list
(mtext "" "Babysittings..."))) (mtitle "" "Babysitters")
(next-button "gc-pup-baby-" "Ending, have you finished here?" "gc-end"
(lambda () '()))))
(lambda (fragment arg) (lambda (fragment arg)
(activity-layout fragment)) (activity-layout fragment))
(lambda (fragment arg) (lambda (fragment arg)
...@@ -1136,7 +1227,9 @@ ...@@ -1136,7 +1227,9 @@
(linear-layout (linear-layout
(make-id "") 'vertical fill gc-col (make-id "") 'vertical fill gc-col
(list (list
(mtext "" "end!..."))) (mtitle "" "Finish group composition")
(next-button "gc-pup-baby-" "Ending, have you finished here?" "gc-end"
(lambda () (list (finish-activity 0))))))
(lambda (fragment arg) (lambda (fragment arg)
(activity-layout fragment)) (activity-layout fragment))
(lambda (fragment arg) (lambda (fragment arg)
...@@ -1257,7 +1350,11 @@ ...@@ -1257,7 +1350,11 @@
((eq? (get-current 'observation "none") obs-gp) ((eq? (get-current 'observation "none") obs-gp)
(list (start-activity "group-events" 2 ""))) (list (start-activity "group-events" 2 "")))
(else (else
(list (start-activity "group-composition" 2 "")))) (entity-reset!)
(entity-add-value! "pack" "varchar" (ktv-get (get-current 'pack ()) "unique_id"))
(set-current! 'group-composition-id (entity-record-values db "stream" "group-composition"))
(list
(start-activity "group-composition" 2 ""))))
(list (list
(alert-dialog (alert-dialog
"choose-obs-finish" "choose-obs-finish"
...@@ -1288,37 +1385,17 @@ ...@@ -1288,37 +1385,17 @@
0 'vertical fillwrap gc-bgcol 0 'vertical fillwrap gc-bgcol
(list (list
(text-view (make-id "obs-title") "" 40 fillwrap) (text-view (make-id "obs-title") "" 40 fillwrap)
(linear-layout
(make-id "obs-buttons-bar") 'horizontal fillwrap trans-col '())
(build-fragment "gc-start" (make-id "gc-top") (layout 'fill-parent 400 1 'left 0)) (build-fragment "gc-start" (make-id "gc-top") (layout 'fill-parent 400 1 'left 0))
(build-fragment "events" (make-id "event-holder") (layout 'fill-parent 450 1 'left 0)) (build-fragment "events" (make-id "event-holder") (layout 'fill-parent 450 1 'left 0))
(mbutton "gc-done" "Done" (lambda () (list (finish-activity 0)))))) (mbutton "gc-done" "Done" (lambda () (list (finish-activity 0))))))
(lambda (activity arg) (lambda (activity arg)
(activity-layout activity)) (activity-layout activity))
(lambda (activity arg) (lambda (activity arg)
(msg (get-current 'observation-fragments '()))
(list (list
(update-widget 'linear-layout (get-id "obs-buttons-bar") 'contents
(let ((all-toggles
(map
(lambda (i) (string-append "obs-bar-" (cadr i)))
(get-current 'observation-fragments '()))))
(map
(lambda (frag)
(msg "button-bar" frag)
(let ((id (string-append "obs-bar-" (cadr frag))))
(toggle-button
(make-id id) (car frag) 12 fillwrap "plain"
(lambda (v)
(append
(mclear-toggles-not-me id all-toggles)
(list
(replace-fragment (get-id "gc-top") (cadr frag))))))))
(get-current 'observation-fragments '()))))
(update-widget 'text-view (get-id "obs-title") 'text (update-widget 'text-view (get-id "obs-title") 'text
(string-append (string-append
(get-current 'observation "No observation") (get-current 'observation "No observation")
" with " (ktv-get (get-current 'pack '()) "name"))) " with pack " (ktv-get (get-current 'pack '()) "name")))
)) ))
(lambda (activity) '()) (lambda (activity) '())
(lambda (activity) '()) (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