Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
Dave Griffiths
mongoose-2000
Commits
71cfc76a
Commit
71cfc76a
authored
Sep 09, 2014
by
Dave Griffiths
Browse files
large local db changes for parallel entity edits, review fixes
parent
d1cdb325
Changes
5
Hide whitespace changes
Inline
Side-by-side
android/assets/dbsync.scm
View file @
71cfc76a
...
...
@@ -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 ke
y
;;
write value to memory entit
y
(
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
)
...
...
android/assets/mongoose.scm
View file @
71cfc76a
...
...
@@ -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
)))))
...
...
android/assets/starwisp.scm
View file @
71cfc76a
...
...
@@ -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"
)
(
mspinner
"gc-pup-strength"
list-strength
(
lambda
(
v
)
(
msg
"updating stren"
(
spinner-choice
list-strength
v
)
)
(
set-current!
'entity-type
"group-comp-pup-assoc"
)
(
entity-update-single-value!
(
ktv
"strength"
"varchar"
(
spinner-choice
list-strength
v
)))
'
())))
(
vert
(
mtext
""
"Accuracy"
)