Commit 71cfc76a authored by Dave Griffiths's avatar Dave Griffiths
Browse files

large local db changes for parallel entity edits, review fixes

parent d1cdb325
......@@ -59,60 +59,56 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; db abstraction
;; entity set - for storing and adding to multiple entities in memory
(define (es-search es type)
(cond
((null? es) #f)
((equal? (car (car es)) type) (car es))
(else (es-search (cdr es) type))))
(define (es-add-entity es type ktv-list)
(cond
((null? es) (list (list type ktv-list)))
((equal? (car (car es)) type) (cons (list type ktv-list) (cdr es)))
(else (cons (car es) (es-add-entity (cdr es) type ktv-list)))))
(define es '())
(define (es-ktv-list)
(let ((type (get-current 'entity-type #f)))
(cond
((not type) (msg "es-ktv-list: no current entity type") '())
(else
(let ((s (es-search es type)))
(cond
((not s) (msg "es-ktv-list: no entity for type " type) '())
(else (cadr s))))))))
;; initialise the entity in memory - ktv-list can be empty for a new one
(define (entity-init! db table entity-type ktv-list)
(entity-reset!)
(entity-set! ktv-list)
(set! es (es-add-entity es entity-type ktv-list))
(set-current! 'db db)
(set-current! 'table table)
(set-current! 'entity-type entity-type))
;; init and immediately save the entity to the db
;; means it gets a unique_id
(define (entity-init&save! db table entity-type ktv-list)
(entity-init! db table entity-type ktv-list)
(let ((id (entity-create! db table entity-type ktv-list)))
(msg "1")
(entity-set-value! "unique_id" "varchar" id)
(msg "2")
id))
;; store a ktv, replaces existing with same key
;;(define (entity-add-value! key type value)
;; (set-current!
;; 'entity-values
;; (ktv-set
;; (get-current 'entity-values '())
;; (ktv key type value))))
(define (entity-add-value-create! key type value)
(msg "entity-add-value-create!" key type value)
(set-current!
'entity-values
(ktv-set
(get-current 'entity-values '())
(ktv key type value))))
(define (entity-set! ktv-list)
(set-current! 'entity-values ktv-list))
;; get value from current memory entity
(define (entity-get-value key)
(ktv-get (get-current 'entity-values '()) key))
(ktv-get (es-ktv-list) key))
;; version to check the entity has the key
;; write value to memory entity
(define (entity-set-value! key type value)
; (let ((existing-type (ktv-get-type (get-current 'entity-values '()) key)))
; (if (equal? existing-type type)
(set-current!
'entity-values
(ktv-set
(get-current 'entity-values '())
(ktv key type value)))
;;
; (begin
; (msg "entity-set-value! - adding new " key "of type" type "to entity")
; (entity-add-value-create! key type value)))
;; save straight to local db every time
;;(entity-update-single-value! (list key type value))
;; )
)
(set! es (es-add-entity
es (get-current 'entity-type #f)
(ktv-set (es-ktv-list) (ktv key type value)))))
(define (date-time->string dt)
(string-append
......@@ -123,16 +119,15 @@
(substring (number->string (+ (list-ref dt 4) 100)) 1 3) ":"
(substring (number->string (+ (list-ref dt 5) 100)) 1 3)))
;; build entity from all ktvs, insert to db, return unique_id
;; build new entity from all memory ktvs, insert to db, return unique_id
(define (entity-record-values!)
(let ((db (get-current 'db #f))
(table (get-current 'table #f))
(type (get-current 'entity-type #f)))
;; standard bits
(let ((r (entity-create! db table type (get-current 'entity-values '()))))
(entity-reset!) r)))
(entity-create! db table type (es-ktv-list))))
;; used internally
(define (entity-create! db table entity-type ktv-list)
(msg "creating:" entity-type ktv-list)
(let ((values
......@@ -151,15 +146,13 @@
(msg "entity-create: " entity-type)
r)))
;; updates existing db entity from memory values
(define (entity-update-values!)
(let ((db (get-current 'db #f))
(table (get-current 'table #f)))
(msg "entity-update-values" db table)
(msg (get-current 'entity-values '()))
;; standard bits
(let ((values (get-current 'entity-values '()))
(unique-id (ktv-get (get-current 'entity-values '()) "unique_id")))
(let* ((values (es-ktv-list))
(unique-id (ktv-get values "unique_id")))
(cond
((and unique-id (not (null? values)))
(msg "entity-update-values inner" values)
......@@ -170,11 +163,12 @@
(else
(msg "no values or no id to update as entity:" unique-id "values:" values))))))
;; updates memory and writes a single value to the db
(define (entity-update-single-value! ktv)
(entity-set-value! (ktv-key ktv) (ktv-type ktv) (ktv-value ktv))
(let ((db (get-current 'db #f))
(table (get-current 'table #f))
(unique-id (ktv-get (get-current 'entity-values '()) "unique_id")))
(unique-id (ktv-get (es-ktv-list) "unique_id")))
(cond
(unique-id
(update-entity db table (entity-id-from-unique db table unique-id) (list ktv)))
......@@ -182,12 +176,6 @@
(msg "no values or no id to update as entity:" unique-id "values:" ktv)))))
(define (entity-reset!)
(set-current! 'entity-values '())
(set-current! 'db "reset")
(set-current! 'table "reset")
(set-current! 'entity-type "reset"))
(define (assemble-array entities)
(foldl
(lambda (i r)
......
......@@ -426,7 +426,7 @@
(date->string (date-minus-months (date-time) 6))))))
(define (tri-state id text key)
(define (tri-state entity-type id text key)
(linear-layout
(make-id "") 'vertical (layout 'fill-parent 'wrap-content '1 'centre 0) trans-col
(list
......@@ -438,6 +438,7 @@
(lambda (v)
(cond
(v
(set-current! 'entity-type entity-type)
(entity-set-value! key "varchar" "yes")
(list
(update-widget 'toggle-button (get-id (string-append id "-n")) 'checked 0)
......@@ -451,6 +452,7 @@
(lambda (v)
(cond
(v
(set-current! 'entity-type entity-type)
(entity-set-value! key "varchar" "maybe")
(list
(update-widget 'toggle-button (get-id (string-append id "-y")) 'checked 0)
......@@ -465,6 +467,7 @@
(lambda (v)
(cond
(v
(set-current! 'entity-type entity-type)
(entity-set-value! key "varchar" "no")
(list
(update-widget 'toggle-button (get-id (string-append id "-y")) 'checked 0)
......@@ -619,12 +622,14 @@
(mbutton "review-item-cancel" "Cancel" (lambda () (list (finish-activity 0))))
(mbutton (string-append uid "-save") "Save"
(lambda ()
(let ((new-entity (review-validate-contents uid (get-current 'entity-values '()))))
(let* ((values (es-ktv-list))
(new-entity (review-validate-contents uid values)))
(cond
((list? new-entity)
;; replace with converted ids
(set-current! 'entity-values new-entity)
;;(entity-update-values!)
(set! es (es-add-entity es (get-current 'entity-type #f) new-entity))
;;(set-current! 'entity-values new-entity)
(entity-update-values!)
(list (finish-activity 0)))
(else
(list
......@@ -645,7 +650,7 @@
(get-id "review-item-container")
'contents
(review-build-contents
uid (get-current 'entity-values '()))))))
uid (es-ktv-list))))))
(define (review-update-list)
(list
......@@ -659,17 +664,32 @@
(time (ktv-get entity "time"))
(type (list-ref data 0))
(uid (list-ref data 1)))
(if (or (equal? type "group-comp")
(equal? type "pup-focal"))
(cons
(mbutton
(string-append "review-" uid)
(string-append type (if time (string-append "-" time) ""))
(lambda ()
(set-current! 'review-collection uid)
(entity-init! db "stream" type (get-entity-by-unique db "stream" uid))
(list (start-activity "review-collection" 0 ""))))
r) r)))
(cond
((or (equal? type "group-comp")
(equal? type "pup-focal"))
(cons
(mbutton
(string-append "review-" uid)
(string-append type (if time (string-append "-" time) ""))
(lambda ()
(set-current! 'review-collection uid)
(entity-init! db "stream" type (get-entity-by-unique db "stream" uid))
(list (start-activity "review-collection" 0 ""))))
r))
((or (equal? type "group-interaction")
(equal? type "group-alarm")
(equal? type "group-move")
(equal? type "note"))
(cons
(mbutton
(string-append "review-" uid)
(string-append type (if time (string-append "-" time) ""))
(lambda ()
(entity-init! db "stream" type (get-entity-by-unique db "stream" uid))
(list (start-activity "review-item" 0 ""))))
r))
(else r))
))
'()
(dirty-entities-for-review db "stream")))))
......@@ -678,24 +698,21 @@
(list
(update-widget
'linear-layout (get-id "review-list") 'contents
(foldl
(lambda (dirty-entity r)
(map
(lambda (dirty-entity)
;; consists of ((type,uid,dirty,version) (ktvlist))
(let* ((data (car dirty-entity))
(entity (cadr dirty-entity))
(time (ktv-get entity "time"))
(type (list-ref data 0))
(uid (list-ref data 1)))
(if (equal? (ktv-get entity "parent") parent-uid)
(cons
(mbutton
(string-append "review-" uid)
(string-append type (if time (string-append "-" time) ""))
(lambda ()
(entity-init! db "stream" type (get-entity-by-unique db "stream" uid))
(list (start-activity "review-item" 0 ""))))
r) r)))
'()
(mbutton
(string-append "review-" uid)
(string-append type (if time (string-append "-" time) ""))
(lambda ()
(entity-init! db "stream" type (get-entity-by-unique db "stream" uid))
(list (start-activity "review-item" 0 ""))))
))
(dirty-entities-for-review-parent db "stream" parent-uid)))))
......
......@@ -89,6 +89,7 @@
(build-grid-selector "pf-scan-close" "toggle" "Mongooses within 2m")
(mbutton "pf-scan-done" "Done"
(lambda ()
(set-current! 'entity-type "pup-focal-nearest")
(entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
(entity-record-values!)
(list (replace-fragment (get-id "pf-top") "pf-timer"))))))
......@@ -105,12 +106,14 @@
"pf-scan-nearest" "single"
(db-mongooses-by-pack-adults) #t
(lambda (individual)
(set-current! 'entity-type "pup-focal-nearest")
(entity-set-value! "id-nearest" "varchar" (ktv-get individual "unique_id"))
(list)))
(populate-grid-selector
"pf-scan-close" "toggle"
(db-mongooses-by-pack-adults) #t
(lambda (individuals)
(set-current! 'entity-type "pup-focal-nearest")
(entity-set-value! "id-list-close" "varchar" (assemble-array individuals))
(list)))
))
......@@ -132,11 +135,13 @@
(mtext "text" "Food size")
(mspinner "pf-pupfeed-size" list-sizes
(lambda (v)
(set-current! 'entity-type "pup-focal-pupfeed")
(entity-set-value! "size" "varchar" (spinner-choice list-sizes v)) '())))
(spacer 20)
(horiz
(mbutton "pf-pupfeed-done" "Done"
(lambda ()
(set-current! 'entity-type "pup-focal-pupfeed")
(entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
(entity-record-values!)
(list (replace-fragment (get-id "event-holder") "events"))))
......@@ -153,6 +158,7 @@
"pf-pupfeed-who" "single"
(db-mongooses-by-pack-adults) #t
(lambda (individual)
(set-current! 'entity-type "pup-focal-pupfeed")
(entity-set-value! "id-who" "varchar" (ktv-get individual "unique_id"))
(list)))
))
......@@ -170,11 +176,14 @@
(horiz
(mtext "text" "Food size")
(mspinner "pf-pupfind-size" list-sizes
(lambda (v) (entity-set-value! "size" "varchar" (spinner-choice list-sizes v)) '())))
(lambda (v)
(set-current! 'entity-type "pup-focal-pupfind")
(entity-set-value! "size" "varchar" (spinner-choice list-sizes v)) '())))
(spacer 20)
(horiz
(mbutton "pf-pupfind-done" "Done"
(lambda ()
(set-current! 'entity-type "pup-focal-pupfind")
(entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
(entity-record-values!)
(list (replace-fragment (get-id "event-holder") "events"))))
......@@ -206,11 +215,13 @@
(mtext "text" "Type of care")
(mspinner "pf-pupcare-type" list-pupcare-type
(lambda (v)
(set-current! 'entity-type "pup-focal-pupcare")
(entity-set-value! "type" "varchar" (spinner-choice list-pupcare-type v)) '())))
(spacer 20)
(horiz
(mbutton "pf-pupcare-done" "Done"
(lambda ()
(set-current! 'entity-type "pup-focal-pupcare")
(entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
(entity-record-values!)
(list (replace-fragment (get-id "event-holder") "events"))))
......@@ -227,6 +238,7 @@
"pf-pupcare-who" "single"
(db-mongooses-by-pack-adults) #t
(lambda (individual)
(set-current! 'entity-type "pup-focal-pupcare")
(entity-set-value! "id-who" "varchar" (ktv-get individual "unique_id"))
(list)))
))
......@@ -250,26 +262,29 @@
(mtext "" "Fighting over")
(mspinner "pf-pupaggr-over" list-aggression-over
(lambda (v)
(set-current! 'entity-type "pup-focal-pupaggr")
(entity-set-value! "over" "varchar" (spinner-choice list-aggression-over v)) '())))
(vert
(mtext "" "Level")
(mspinner "pf-pupaggr-level" list-aggression-level
(lambda (v)
(set-current! 'entity-type "pup-focal-pupaggr")
(entity-set-value! "level" "varchar" (spinner-choice list-aggression-level v)) '())))
(tri-state "pf-pupaggr-in" "Initiate?" "initiate")
(tri-state "pup-focal-pupaggr" "pf-pupaggr-in" "Initiate?" "initiate")
;(mtoggle-button "pf-pupaggr-in" "Initiate?"
; (lambda (v)
; (entity-set-value! "initiate" "varchar" (if v "yes" "no")) '()))
(tri-state "pf-pupaggr-win" "Win?" "win")))
(tri-state "pup-focal-pupaggr" "pf-pupaggr-win" "Win?" "win")))
(spacer 10)
(horiz
(mbutton "pf-pupaggr-done" "Done"
(lambda ()
(set-current! 'entity-type "pup-focal-pupaggr")
(entity-set-value! "parent" "varchar" (get-current 'pup-focal-id ""))
(entity-record-values!)
(list (replace-fragment (get-id "event-holder") "events"))))
......@@ -287,6 +302,7 @@
"pf-pupaggr-partner" "single"
(db-mongooses-by-pack) #t
(lambda (individual)
(set-current! 'entity-type "pup-focal-pupaggr")
(entity-set-value! "id-with" "varchar" (ktv-get individual "unique_id"))
(list)))
))
......@@ -310,16 +326,20 @@
(mtext "text" "Outcome")
(mspinner "gp-int-out" list-interaction-outcome
(lambda (v)
(set-current! 'entity-type "group-interaction")
(entity-set-value! "outcome" "varchar" (spinner-choice list-interaction-outcome v)) '()))
(mtext "text" "Duration")
(edit-text (make-id "gp-int-dur") "" 30 "numeric" fillwrap
(lambda (v) (entity-set-value! "duration" "int" (string->number v)) '()))))
(lambda (v)
(set-current! 'entity-type "group-interaction")
(entity-set-value! "duration" "int" (string->number v)) '()))))
(build-grid-selector "gp-int-pack" "single" "Other pack"))
(linear-layout
(make-id "") 'horizontal (layout 'fill-parent 80 '1 'left 0) trans-col
(list
(mbutton "pf-grpint-done" "Done"
(lambda ()
(set-current! 'entity-type "group-interaction")
(entity-record-values!)
(list (replace-fragment (get-id "event-holder") "events"))))
(mbutton "pf-grpint-cancel" "Cancel"
......@@ -338,12 +358,14 @@
"gp-int-pack" "single"
(db-mongoose-packs) #f
(lambda (pack)
(set-current! 'entity-type "group-interaction")
(entity-set-value! "id-other-pack" "varchar" (ktv-get pack "unique_id"))
(list)))
(populate-grid-selector
"gp-int-leader" "single"
(db-mongooses-by-pack) #t
(lambda (individual)
(set-current! 'entity-type "group-interaction")
(entity-set-value! "id-leader" "varchar" (ktv-get individual "unique_id"))
(list)))
)))
......@@ -368,13 +390,15 @@
(mtext "text" "Cause")
(mspinner "gp-alarm-cause" list-alarm-cause
(lambda (v)
(set-current! 'entity-type "group-alarm")
(entity-set-value! "cause" "varchar" (spinner-choice list-alarm-cause v)) '())))
(tri-state "gp-alarm-join" "Did the others join in?" "others-join")))
(tri-state "group-alarm" "gp-alarm-join" "Did the others join in?" "others-join")))
(horiz
(mbutton "pf-grpalarm-done" "Done"
(lambda ()
(set-current! 'entity-type "group-alarm")
(entity-record-values!)
(list (replace-fragment (get-id "event-holder") "events"))))
(mbutton "pf-grpalarm-cancel" "Cancel"
......@@ -392,6 +416,7 @@
"gp-alarm-caller" "single"
(db-mongooses-by-pack) #t
(lambda (individual)
(set-current! 'entity-type "group-alarm")
(entity-set-value! "id-caller" "varchar" (ktv-get individual "unique_id"))
(list))))
))
......@@ -410,28 +435,39 @@
(make-id "") 'horizontal (layout 'fill-parent 'wrap-content '1 'left 0) trans-col
(list
(medit-text "gp-mov-w" "Pack width" "numeric"
(lambda (v) (entity-set-value! "pack-width" "int" (string->number v)) '()))
(lambda (v)
(set-current! 'entity-type "group-move")
(entity-set-value! "pack-width" "int" (string->number v)) '()))
(medit-text "gp-mov-l" "Pack depth" "numeric"
(lambda (v) (entity-set-value! "pack-depth" "int" (string->number v)) '()))
(lambda (v)
(set-current! 'entity-type "group-move")
(entity-set-value! "pack-depth" "int" (string->number v)) '()))
(medit-text "gp-mov-c" "How many?" "numeric"
(lambda (v) (entity-set-value! "pack-count" "int" (string->number v)) '()))))
(lambda (v)
(set-current! 'entity-type "group-move")
(entity-set-value! "pack-count" "int" (string->number v)) '()))))
(linear-layout
(make-id "") 'horizontal (layout 'fill-parent 'wrap-content '1 'left 0) trans-col
(list
(vert
(mtext "" "Direction")
(mspinner "gp-mov-dir" list-move-direction
(lambda (v) (entity-set-value! "direction" "varchar" (spinner-choice list-move-direction v)) '())))
(lambda (v)
(set-current! 'entity-type "group-move")
(entity-set-value! "direction" "varchar" (spinner-choice list-move-direction v)) '())))
(vert
(mtext "" "Where to")
(mspinner "gp-mov-to" list-move-to
(lambda (v) (entity-set-value! "destination" "varchar" (spinner-choice list-move-to v)) '())))))
(lambda (v)
(set-current! 'entity-type "group-move")
(entity-set-value! "destination" "varchar" (spinner-choice list-move-to v)) '())))))
(spacer 20)
(horiz
(mbutton "pf-grpmov-done" "Done"
(lambda ()
(set-current! 'entity-type "group-move")
(entity-record-values!)
(list (replace-fragment (get-id "event-holder") "events"))))
(mbutton "pf-grpalarm-cancel" "Cancel"
......@@ -449,6 +485,7 @@
"gp-mov-leader" "single"
(db-mongooses-by-pack) #t
(lambda (individual)
(set-current! 'entity-type "group-move")
(entity-set-value! "id-leader" "varchar" (ktv-get individual "unique_id"))
(list)))
)))
......@@ -465,11 +502,13 @@
(mtitle "title" "Make a note")
(edit-text (make-id "note-text") "" 30 "text" fillwrap
(lambda (v)
(set-current! 'entity-type "note")
(entity-set-value! "text" "varchar" v)
'()))
(horiz
(mbutton "note-done" "Done"
(lambda ()
(set-current! 'entity-type "note")
(entity-record-values!)
(list (replace-fragment (get-id "event-holder") "events"))))
(mbutton "note-cancel" "Cancel"
......@@ -503,13 +542,17 @@
(mtitle "title" "Start")
(horiz
(mtoggle-button "gc-start-main-obs" "I'm the main observer"
(lambda (v) (entity-update-single-value!
(ktv "main-observer" "varchar" v)) '()))
(lambda (v)
(set-current! 'entity-type "group-comp")
(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-update-values!
(ktv "group-comp-code" "varchar" v)) '()))))
(lambda (v)
(set-current! 'entity-type "group-comp")
(entity-update-values!
(ktv "group-comp-code" "varchar" v)) '()))))
(mtitle "title" "Weights")
(build-grid-selector "gc-weigh-choose" "single" "Choose mongoose")
......@@ -517,14 +560,17 @@
(horiz
(edit-text (make-id "gc-weigh-weight") "" 30 "numeric" fillwrap
(lambda (v)
(set-current! 'entity-type "group-comp-weight")
(entity-update-single-value! (ktv "weight" "real" (string->number v)))
'()))
(mtoggle-button "gc-weigh-accurate" "Accurate?"
(lambda (v)
(set-current! 'entity-type "group-comp-weight")
(entity-update-single-value! (ktv "accurate" "int" (if v 1 0)))
'()))
(mtoggle-button "gc-weigh-present" "Present but not weighed"
(lambda (v)
(set-current! 'entity-type "group-comp-weight")
(entity-update-single-value! (ktv "present" "int" (if v 1 0)))
'()))
)
......@@ -532,6 +578,7 @@
(next-button "gc-start-" "Go to pregnant females, have you finished here?" "gc-start" "gc-preg"
(lambda ()
(set-current! 'entity-type "group-comp")
(entity-update-values!)
;; reset main entity
......@@ -552,7 +599,11 @@
(list (list "parent" "varchar" "=" (get-current 'group-composition-id #f)))))
)))
(set-current! 'gc-not-present (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") #\,)))
'()))
))
......@@ -678,6 +729,7 @@
"gc-preg-choose" "toggle"
(db-mongooses-by-pack-female) #f
(lambda (individuals)
(set-current! 'entity-type "group-comp")
(entity-update-single-value! (ktv "pregnant" "varchar" (assemble-array individuals)))
(list)))
)
......@@ -701,14 +753,14 @@
(mtext "" "Strength")
(mspin