Commit 53834c24 authored by Dave Griffiths's avatar Dave Griffiths
Browse files

group comp working again, layout fixes

parent cb6bdfdf
...@@ -17,6 +17,7 @@ ...@@ -17,6 +17,7 @@
(msg "dbsync.scm") (msg "dbsync.scm")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; stuff in memory ;; stuff in memory
...@@ -106,7 +107,6 @@ ...@@ -106,7 +107,6 @@
;; ) ;; )
) )
(define (date-time->string dt) (define (date-time->string dt)
(string-append (string-append
(number->string (list-ref dt 0)) "-" (number->string (list-ref dt 0)) "-"
...@@ -148,14 +148,17 @@ ...@@ -148,14 +148,17 @@
(define (entity-update-values!) (define (entity-update-values!)
(let ((db (get-current 'db #f)) (let ((db (get-current 'db #f))
(table (get-current 'table #f))) (table (get-current 'table #f)))
(msg "entity-update-values" db table)
(msg (get-current 'entity-values '()))
;; standard bits ;; standard bits
(let ((values (get-current 'entity-values '())) (let ((values (get-current 'entity-values '()))
(unique-id (ktv-get (get-current 'entity-values '()) "unique_id"))) (unique-id (ktv-get (get-current 'entity-values '()) "unique_id")))
(cond (cond
((and unique-id (not (null? values))) ((and unique-id (not (null? values)))
(msg "entity-update-values inner" values)
(update-entity db table (entity-id-from-unique db table unique-id) values) (update-entity db table (entity-id-from-unique db table unique-id) values)
;; removed due to save button no longer exiting activity - need to keep! ;; removed due to save button no longer exiting activity - need to keep!
(entity-reset!) ;;(entity-reset!)
) )
(else (else
(msg "no values or no id to update as entity:" unique-id "values:" values)))))) (msg "no values or no id to update as entity:" unique-id "values:" values))))))
...@@ -168,7 +171,7 @@ ...@@ -168,7 +171,7 @@
(unique-id (unique-id
(update-entity db table (entity-id-from-unique db table unique-id) (list ktv))) (update-entity db table (entity-id-from-unique db table unique-id) (list ktv)))
(else (else
(msg "no values or no id to update as entity:" unique-id "values:" values))))) (msg "no values or no id to update as entity:" unique-id "values:" value)))))
(define (entity-reset!) (define (entity-reset!)
......
...@@ -656,10 +656,10 @@ ...@@ -656,10 +656,10 @@
(* (/ (prof-item-accum d) tot) 100) "%")) (* (/ (prof-item-accum d) tot) 100) "%"))
prof-map))) prof-map)))
(define wrap (layout 'wrap-content 'wrap-content -1 'left 0)) (define wrap (layout 'wrap-content 'wrap-content 1 'left 0))
(define fillwrap (layout 'fill-parent 'wrap-content -1 'left 0)) (define fillwrap (layout 'fill-parent 'wrap-content 1 'left 0))
(define wrapfill (layout 'wrap-content 'fill-parent -1 'left 0)) (define wrapfill (layout 'wrap-content 'fill-parent 1 'left 0))
(define fill (layout 'fill-parent 'fill-parent -1 'left 0)) (define fill (layout 'fill-parent 'fill-parent 1 'left 0))
(define (spacer size) (space (layout 'fill-parent size 1 'left 0))) (define (spacer size) (space (layout 'fill-parent size 1 'left 0)))
...@@ -681,7 +681,7 @@ ...@@ -681,7 +681,7 @@
(define (vert . l) (define (vert . l)
(linear-layout (linear-layout
0 'vertical 0 'vertical
(layout 'fill-parent 'fill-parent -1 'centre 20) (layout 'fill-parent 'wrap-content 1 'centre 20)
(list 0 0 0 0) (list 0 0 0 0)
l)) l))
......
...@@ -40,6 +40,7 @@ ...@@ -40,6 +40,7 @@
"pup-focal-pupcare" "pup-focal-pupcare"
"pup-focal-pupaggr")) "pup-focal-pupaggr"))
(define list-sizes (list "Small" "Medium" "Large"))
;; colours ;; colours
...@@ -102,41 +103,41 @@ ...@@ -102,41 +103,41 @@
;; user interface abstraction ;; user interface abstraction
(define (mbutton id title fn) (define (mbutton id title fn)
(button (make-id id) title 30 (layout 'fill-parent 'wrap-content 1 'centre 10) fn)) (button (make-id id) title 20 (layout 'fill-parent 'wrap-content 1 'centre 5) fn))
(define (mbutton2 id title fn) (define (mbutton2 id title fn)
(button (make-id id) title 30 (layout 150 100 1 'centre 10) fn)) (button (make-id id) title 20 (layout 150 100 1 'centre 5) fn))
(define (mtoggle-button id title fn) (define (mtoggle-button id title fn)
(toggle-button (make-id id) title 30 (layout 'fill-parent 'wrap-content 1 'centre 10) "fancy" fn)) (toggle-button (make-id id) title 20 (layout 'fill-parent 'wrap-content 1 'centre 5) "fancy" fn))
(define (mtoggle-button-yes id title fn) (define (mtoggle-button-yes id title fn)
(toggle-button (make-id id) title 30 (layout 49 43 1 'centre 0) "yes" fn)) (toggle-button (make-id id) title 20 (layout 49 43 1 'centre 0) "yes" fn))
(define (mtoggle-button-maybe id title fn) (define (mtoggle-button-maybe id title fn)
(toggle-button (make-id id) title 30 (layout 49 43 1 'centre 0) "maybe" fn)) (toggle-button (make-id id) title 20 (layout 49 43 1 'centre 0) "maybe" fn))
(define (mtoggle-button-no id title fn) (define (mtoggle-button-no id title fn)
(toggle-button (make-id id) title 30 (layout 49 43 1 'centre 0) "no" fn)) (toggle-button (make-id id) title 20 (layout 49 43 1 'centre 0) "no" fn))
(define (mtoggle-button2 id title fn) (define (mtoggle-button2 id title fn)
(toggle-button (make-id id) title 30 (layout 150 100 1 'centre 10) "plain" fn)) (toggle-button (make-id id) title 20 (layout 150 100 1 'centre 5) "plain" fn))
(define (mtext id text) (define (mtext id text)
(text-view (make-id id) text 30 fillwrap)) (text-view (make-id id) text 20 fillwrap))
(define (mtitle id text) (define (mtitle id text)
(text-view (make-id id) text 50 fillwrap)) (text-view (make-id id) text 40 fillwrap))
(define (medit-text id text type fn) (define (medit-text id text type fn)
(vert (vert
(mtext (string-append id "-title") text) (mtext (string-append id "-title") text)
(edit-text (make-id id) "" 30 type fillwrap fn))) (edit-text (make-id id) "" 20 type fillwrap fn)))
(define (medit-text-value id text value type fn) (define (medit-text-value id text value type fn)
(vert (vert
(mtext (string-append id "-title") text) (mtext (string-append id "-title") text)
(edit-text (make-id id) value 30 type fillwrap fn))) (edit-text (make-id id) value 20 type fillwrap fn)))
(define (mclear-toggles id-list) (define (mclear-toggles id-list)
(map (map
...@@ -177,13 +178,13 @@ ...@@ -177,13 +178,13 @@
(image-view (make-id "im") "arrow_left" (layout 200 'fill-parent 1 'left 0)) (image-view (make-id "im") "arrow_left" (layout 200 'fill-parent 1 'left 0))
(scroll-view (scroll-view
(make-id "scroller") (make-id "scroller")
(layout 'wrap-content 'wrap-content 1 'left 20) (layout 'wrap-content 'wrap-content 1 'left 5)
(list (list
(linear-layout (linear-layout
(make-id name) 'horizontal (make-id name) 'horizontal
(layout 'wrap-content 'wrap-content 1 'centre 20) trans-col (layout 'wrap-content 'wrap-content 1 'centre 5) trans-col
(list (list
(button-grid (make-id name) type 3 30 (layout 100 60 1 'left 40) (button-grid (make-id name) type 3 20 (layout 100 60 1 'left 5)
(list) (lambda (v) '())))))) (list) (lambda (v) '()))))))
(image-view (make-id "im") "arrow_right" (layout 200 'fill-parent 1 'right 0))))))) (image-view (make-id "im") "arrow_right" (layout 200 'fill-parent 1 'right 0)))))))
...@@ -217,7 +218,7 @@ ...@@ -217,7 +218,7 @@
(let ((r (update-widget (let ((r (update-widget
'button-grid (get-id name) 'grid-buttons 'button-grid (get-id name) 'grid-buttons
(list (list
type 3 30 (layout 100 60 1 'left 0) type 3 20 (layout 80 50 1 'left 2)
(map (map
(lambda (ii) (lambda (ii)
(list (car ii) (caddr ii))) (list (car ii) (caddr ii)))
...@@ -347,30 +348,40 @@ ...@@ -347,30 +348,40 @@
(define (review-build-contents uid entity) (define (review-build-contents uid entity)
(msg "review-build-contents") (msg "review-build-contents")
(append (append
(map (foldl
(lambda (ktv) (lambda (ktv r)
(cond (append
((equal? (ktv-type ktv) "varchar") r (cond
(medit-text-value (string-append uid (ktv-key ktv)) ((or (equal? (ktv-key ktv) "unique_id")
(ktv-key ktv) (equal? (ktv-key ktv) "deleted")) '())
(ktv-value ktv) "normal" ((equal? (ktv-type ktv) "varchar")
(lambda (v) '()))) (list (medit-text-value (string-append uid (ktv-key ktv))
((equal? (ktv-type ktv) "int") (ktv-key ktv)
(medit-text-value (string-append uid (ktv-key ktv)) (ktv-value ktv) "normal"
(ktv-key ktv) (lambda (v)
(number->string (ktv-value ktv)) "numeric" (entity-set-value! (ktv-key ktv) (ktv-type ktv) v) '()))))
(lambda (v) '()))) ((equal? (ktv-type ktv) "int")
((equal? (ktv-type ktv) "real") (list (medit-text-value (string-append uid (ktv-key ktv))
(medit-text-value (string-append uid (ktv-key ktv)) (ktv-key ktv)
(ktv-key ktv) (number->string (ktv-value ktv)) "numeric"
(number->string (ktv-value ktv)) "numeric" (lambda (v)
(lambda (v) '()))) (entity-set-value! (ktv-key ktv) (ktv-type ktv) v) '()))))
(else (mtext "" (string-append (ktv-type ktv) " not handled"))))) ((equal? (ktv-type ktv) "real")
(list (medit-text-value (string-append uid (ktv-key ktv))
(ktv-key ktv)
(number->string (ktv-value ktv)) "numeric"
(lambda (v)
(entity-set-value! (ktv-key ktv) (ktv-type ktv) v) '()))))
(else (mtext "" (string-append (ktv-type ktv) " not handled")) '()))))
'()
entity) entity)
(list (list
(horiz (horiz
(mbutton "review-item-cancel" "Cancel" (lambda () (list (finish-activity 0)))) (mbutton "review-item-cancel" "Cancel" (lambda () (list (finish-activity 0))))
(mbutton (string-append uid "-save") "Save" (lambda () '())))))) (mbutton (string-append uid "-save") "Save"
(lambda ()
(entity-update-values!)
(list (finish-activity 0))))))))
(define (review-item-build) (define (review-item-build)
(let ((uid (entity-get-value "unique_id"))) (let ((uid (entity-get-value "unique_id")))
...@@ -468,19 +479,21 @@ ...@@ -468,19 +479,21 @@
))) )))
(define (next-button id dialog-msg next-frag fn) (define (next-button id dialog-msg next-frag fn)
(mbutton (string-append id "-nextb") "Next" (mbutton (string-append id "-nextb") "Next"
(lambda () (lambda ()
(list (list
(alert-dialog (alert-dialog
(string-append id "-d") (string-append id "-d")
dialog-msg dialog-msg
(lambda (v) (lambda (v)
(cond (cond
((eqv? v 1) ((eqv? v 1)
(append (msg "recording from next button")
(fn) (list (replace-fragment (entity-update-values!)
(get-id "gc-top") next-frag)))) (append
(else '())))))))) (fn) (list (replace-fragment
(get-id "gc-top") next-frag))))
(else '()))))))))
(define (force-pause) (define (force-pause)
(list (list
...@@ -601,9 +614,9 @@ ...@@ -601,9 +614,9 @@
(spacer 20) (spacer 20)
(horiz (horiz
(mtext "text" "Food size") (mtext "text" "Food size")
(spinner (make-id "pf-pupfeed-size") (list "Small" "Medium" "Large") fillwrap (spinner (make-id "pf-pupfeed-size") list-sizes fillwrap
(lambda (v) (lambda (v)
(entity-set-value! "size" "varchar" v) '()))) (entity-set-value! "size" "varchar" (list-ref list-sizes v)) '())))
(spacer 20) (spacer 20)
(horiz (horiz
(mbutton "pf-pupfeed-done" "Done" (mbutton "pf-pupfeed-done" "Done"
...@@ -879,7 +892,7 @@ ...@@ -879,7 +892,7 @@
(list (list
(build-grid-selector "gp-mov-leader" "single" "<b>Group movement</b>: Leader") (build-grid-selector "gp-mov-leader" "single" "<b>Group movement</b>: Leader")
(linear-layout (linear-layout
(make-id "") 'horizontal (layout 'fill-parent 90 '1 'left 0) trans-col (make-id "") 'horizontal (layout 'fill-parent 'wrap-content '1 'left 0) trans-col
(list (list
(medit-text "gp-mov-w" "Pack width" "numeric" (medit-text "gp-mov-w" "Pack width" "numeric"
(lambda (v) (entity-set-value! "pack-width" "int" (string->number v)) '())) (lambda (v) (entity-set-value! "pack-width" "int" (string->number v)) '()))
...@@ -986,19 +999,15 @@ ...@@ -986,19 +999,15 @@
(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-set-value!
(list (list
(populate-grid-selector (populate-grid-selector
"gc-start-present" "toggle" "gc-start-present" "toggle"
(db-mongooses-by-pack) #f (db-mongooses-by-pack) #f
(lambda (individual) (lambda (individual)
(lambda (v) (entity-set-value! "group-comp-code" "varchar" v) '())) (lambda (v) (entity-set-value! "present" "varchar" v) '()))
(list)))
(list))) )
))
(lambda (fragment) '()) (lambda (fragment) '())
(lambda (fragment) '()) (lambda (fragment) '())
(lambda (fragment) '()) (lambda (fragment) '())
...@@ -1279,21 +1288,21 @@ ...@@ -1279,21 +1288,21 @@
(mtext "type" "Choose observation type") (mtext "type" "Choose observation type")
(horiz (horiz
(linear-layout (linear-layout
0 'vertical wrap gc-col 0 'vertical fillwrap gc-col
(list (list
(mtoggle-button2 "choose-obs-gc" obs-gc (mtoggle-button2 "choose-obs-gc" obs-gc
(lambda (v) (lambda (v)
(set-current! 'observation obs-gc) (set-current! 'observation obs-gc)
(mclear-toggles (list "choose-obs-pf" "choose-obs-gp")))))) (mclear-toggles (list "choose-obs-pf" "choose-obs-gp"))))))
(linear-layout (linear-layout
0 'vertical wrap pf-col 0 'vertical fillwrap pf-col
(list (list
(mtoggle-button2 "choose-obs-pf" obs-pf (mtoggle-button2 "choose-obs-pf" obs-pf
(lambda (v) (lambda (v)
(set-current! 'observation obs-pf) (set-current! 'observation obs-pf)
(mclear-toggles (list "choose-obs-gc" "choose-obs-gp")))))) (mclear-toggles (list "choose-obs-gc" "choose-obs-gp"))))))
(linear-layout (linear-layout
0 'vertical wrap gp-col 0 'vertical fillwrap gp-col
(list (list
(mtoggle-button2 "choose-obs-gp" obs-gp (mtoggle-button2 "choose-obs-gp" obs-gp
(lambda (v) (lambda (v)
...@@ -1324,9 +1333,15 @@ ...@@ -1324,9 +1333,15 @@
((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
(entity-reset!) ;; create a new gc entity
(entity-set-value! "pack" "varchar" (ktv-get (get-current 'pack ()) "unique_id")) (set-current!
(set-current! 'group-composition-id (entity-record-values! db "stream" "group-composition")) 'group-composition-id
(entity-create!
db "stream" "group-composition"
(list (ktv "pack" "varchar" (ktv-get (get-current 'pack ()) "unique_id")))))
;; initialise it to the current memory entity
(entity-init! db "sync" "individual"
(get-entity-by-unique db "sync" (get-current 'group-composition-id #f)))
(list (list
(start-activity "group-composition" 2 "")))) (start-activity "group-composition" 2 ""))))
(list (list
...@@ -1355,16 +1370,17 @@ ...@@ -1355,16 +1370,17 @@
(activity (activity
"group-composition" "group-composition"
(linear-layout (linear-layout
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)
(build-fragment "gc-start" (make-id "gc-top") (layout 'fill-parent 520 1 'left 0)) (build-fragment "gc-start" (make-id "gc-top") (layout 'fill-parent 520 1 'left 0))
(build-fragment "events" (make-id "event-holder") (layout 'fill-parent 520 1 'left 0)) (build-fragment "events" (make-id "event-holder") (layout 'fill-parent 520 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 "creating gc activity")
(list (list
(update-widget 'text-view (get-id "obs-title") 'text (update-widget 'text-view (get-id "obs-title") 'text
(string-append (string-append
......
...@@ -52,12 +52,12 @@ ...@@ -52,12 +52,12 @@
<style name="StarwispTextAppearanceSpinnerItem" parent="android:TextAppearance.Widget.TextView.SpinnerItem"> <style name="StarwispTextAppearanceSpinnerItem" parent="android:TextAppearance.Widget.TextView.SpinnerItem">
<item name="android:textColor">@color/text</item> <item name="android:textColor">@color/text</item>
<item name="android:textSize">50sp</item> <item name="android:textSize">20sp</item>
</style> </style>
<style name="StarwispSpinner" parent="android:style/Widget.Spinner"> <style name="StarwispSpinner" parent="android:style/Widget.Spinner">
<item name="android:textColor">@color/text</item> <item name="android:textColor">@color/text</item>
<item name="android:textSize">50sp</item> <item name="android:textSize">20sp</item>
<item name="android:background">@drawable/swarmspinner</item> <item name="android:background">@drawable/swarmspinner</item>
</style> </style>
......
...@@ -35,14 +35,24 @@ ...@@ -35,14 +35,24 @@
(msg "hello from eavdb.ss") (msg "hello from eavdb.ss")
(define (upgrade-table db name)
(db-exec db (string-append "alter table " name " add column version integer")))
;; create eav tables (add types as required) ;; create eav tables (add types as required)
(define (setup db table) (define (setup db table)
(msg "db setup")
(db-exec db (string-append "create table " table "_entity ( entity_id integer primary key autoincrement, entity_type varchar(256), unique_id varchar(256), dirty integer, version integer)")) (db-exec db (string-append "create table " table "_entity ( entity_id integer primary key autoincrement, entity_type varchar(256), unique_id varchar(256), dirty integer, version integer)"))
(db-exec db (string-append "create table " table "_attribute ( id integer primary key autoincrement, attribute_id varchar(256), entity_type varchar(256), attribute_type varchar(256))")) (db-exec db (string-append "create table " table "_attribute ( id integer primary key autoincrement, attribute_id varchar(256), entity_type varchar(256), attribute_type varchar(256))"))
(db-exec db (string-append "create table " table "_value_varchar ( id integer primary key autoincrement, entity_id integer, attribute_id varchar(255), value varchar(4096), dirty integer, version integer)")) (db-exec db (string-append "create table " table "_value_varchar ( id integer primary key autoincrement, entity_id integer, attribute_id varchar(255), value varchar(4096), dirty integer, version integer)"))
(upgrade-table db (string-append table "_value_varchar"))
(db-exec db (string-append "create table " table "_value_int ( id integer primary key autoincrement, entity_id integer, attribute_id varchar(255), value integer, dirty integer, version integer)")) (db-exec db (string-append "create table " table "_value_int ( id integer primary key autoincrement, entity_id integer, attribute_id varchar(255), value integer, dirty integer, version integer)"))
(upgrade-table db (string-append table "_value_int"))
(db-exec db (string-append "create table " table "_value_real ( id integer primary key autoincrement, entity_id integer, attribute_id varchar(255), value real, dirty integer, version integer)")) (db-exec db (string-append "create table " table "_value_real ( id integer primary key autoincrement, entity_id integer, attribute_id varchar(255), value real, dirty integer, version integer)"))
(db-exec db (string-append "create table " table "_value_file ( id integer primary key autoincrement, entity_id integer, attribute_id varchar(255), value varchar(4096), dirty integer, version integer)"))) (upgrade-table db (string-append table "_value_real"))
(db-exec db (string-append "create table " table "_value_file ( id integer primary key autoincrement, entity_id integer, attribute_id varchar(255), value varchar(4096), dirty integer, version integer)"))
(upgrade-table db (string-append table "_value_file")))
(define (validate db) (define (validate db)
......
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