Commit ba3e0490 authored by Dave Griffiths's avatar Dave Griffiths
Browse files

loads of stuff for auto lists and adding/updating of entities

parent a684965f
...@@ -58,9 +58,13 @@ ...@@ -58,9 +58,13 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; db abstraction ;; db abstraction
(define (entity-init! ktv-list) (define (entity-init! db table entity-type ktv-list)
(entity-reset!) (entity-reset!)
(entity-set! ktv-list)) (entity-set! ktv-list)
(set-current! 'db db)
(set-current! 'table table)
(set-current! 'entity-type entity-type))
;; store a ktv, replaces existing with same key ;; store a ktv, replaces existing with same key
(define (entity-add-value! key type value) (define (entity-add-value! key type value)
...@@ -73,47 +77,73 @@ ...@@ -73,47 +77,73 @@
(define (entity-set! ktv-list) (define (entity-set! ktv-list)
(set-current! 'entity-values ktv-list)) (set-current! 'entity-values ktv-list))
(define (entity-get-value key)
(ktv-get (get-current 'entity-values '()) key))
;; version to check the entity has the key
(define (entity-set-value! key type value)
(msg "entity-set-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)))
(msg "entity-set-value -" key "of type" type "doesn't exist on this entity"))
(msg "done entity-set-value!")))
(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)) "-"
(number->string (list-ref dt 1)) "-" (substring (number->string (+ (list-ref dt 1) 100)) 1 3) "-"
(number->string (list-ref dt 2)) " " (substring (number->string (+ (list-ref dt 2) 100)) 1 3) " "
(number->string (list-ref dt 3)) ":" (substring (number->string (+ (list-ref dt 3) 100)) 1 3) ":"
(number->string (list-ref dt 4)) ":" (substring (number->string (+ (list-ref dt 4) 100)) 1 3) ":"
(substring (number->string (+ 100 (list-ref dt 5))) 1 2))) (substring (number->string (+ (list-ref dt 5) 100)) 1 3)))
;; build entity from all ktvs, insert to db, return unique_id ;; build entity from all ktvs, insert to db, return unique_id
(define (entity-record-values db table type) (define (entity-record-values!)
;; standard bits (let ((db (get-current 'db #f))
(entity-add-value! "user" "varchar" (get-current 'user-id "none")) (table (get-current 'table #f))
(entity-add-value! "time" "varchar" (date-time->string (date-time))) (type (get-current 'entity-type #f)))
(entity-add-value! "lat" "real" (car (get-current 'location '(0 0)))) ;; standard bits
(entity-add-value! "lon" "real" (cadr (get-current 'location '(0 0)))) (entity-add-value! "user" "varchar" (get-current 'user-id "none"))
(let ((values (get-current 'entity-values '()))) (entity-add-value! "time" "varchar" (date-time->string (date-time)))
(cond (entity-add-value! "lat" "real" (car (get-current 'location '(0 0))))
((not (null? values)) (entity-add-value! "lon" "real" (cadr (get-current 'location '(0 0))))
(let ((r (insert-entity/get-unique (let ((values (get-current 'entity-values '())))
db table type (get-current 'user-id "no id") (cond
values))) ((not (null? values))
(msg "inserted a " type) (let ((r (insert-entity/get-unique
(entity-reset!) r)) db table type (get-current 'user-id "no id")
(else values)))
(msg "no values to add as entity!") #f)))) (msg "inserted a " type)
(entity-reset!) r))
(define (entity-update-values db table) (else
;; standard bits (msg "no values to add as entity!") #f)))
(let ((values (get-current 'entity-values '())) ;; just to be on the safe side
(unique-id (ktv-get (get-current 'entity-values '()) "unique_id"))) (entity-reset!)))
(cond
((and unique-id (not (null? values))) (define (entity-update-values!)
(update-entity db table (entity-id-from-unique db table unique-id) values) (let ((db (get-current 'db #f))
(msg "updated " unique-id) (table (get-current 'table #f)))
(entity-reset!)) ;; standard bits
(else (let ((values (get-current 'entity-values '()))
(msg "no values or no id to update as entity:" unique-id "values:" values))))) (unique-id (ktv-get (get-current 'entity-values '()) "unique_id")))
(cond
((and unique-id (not (null? values)))
(update-entity db table (entity-id-from-unique db table unique-id) values)
(msg "updated " unique-id)
(entity-reset!))
(else
(msg "no values or no id to update as entity:" unique-id "values:" values))))))
(define (entity-reset!) (define (entity-reset!)
(set-current! 'entity-values '())) (set-current! 'entity-values '())
(set-current! 'db "reset")
(set-current! 'table "reset")
(set-current! 'entity-type "reset"))
(define (assemble-array entities) (define (assemble-array entities)
(foldl (foldl
......
...@@ -358,6 +358,13 @@ ...@@ -358,6 +358,13 @@
(ktv-value (car ktv-list))) (ktv-value (car ktv-list)))
(else (ktv-get (cdr ktv-list) key)))) (else (ktv-get (cdr ktv-list) key))))
(define (ktv-get-type ktv-list key)
(cond
((null? ktv-list) #f)
((equal? (ktv-key (car ktv-list)) key)
(ktv-type (car ktv-list)))
(else (ktv-get-type (cdr ktv-list) key))))
(define (ktv-set ktv-list ktv) (define (ktv-set ktv-list ktv)
(cond (cond
((null? ktv-list) (list ktv)) ((null? ktv-list) (list ktv))
...@@ -609,8 +616,11 @@ ...@@ -609,8 +616,11 @@
"select entity_id from " table "_entity where unique_id = ?") "select entity_id from " table "_entity where unique_id = ?")
unique-id)) unique-id))
(define (get-entity-by-unique db table unique-id)
(get-entity db table (get-entity-id db table unique-id)))
(define (get-entity-name db table unique-id) (define (get-entity-name db table unique-id)
(ktv-get (get-entity db table (get-entity-id db table unique-id)) "name")) (ktv-get (get-entity-by-unique db table unique-id) "name"))
(define (get-entity-names db table id-list) (define (get-entity-names db table id-list)
(foldl (foldl
......
...@@ -640,6 +640,13 @@ ...@@ -640,6 +640,13 @@
(list 0 0 0 0) (list 0 0 0 0)
l)) l))
(define (vert-colour col . l)
(linear-layout
0 'vertical
(layout 'fill-parent 'wrap-content 1 'centre 20)
col
l))
(define (vert-fill . l) (define (vert-fill . l)
(linear-layout (linear-layout
0 'vertical 0 'vertical
...@@ -725,7 +732,6 @@ ...@@ -725,7 +732,6 @@
(update-callbacks! c)) (update-callbacks! c))
(let ((cb (widget-get-callback w))) (let ((cb (widget-get-callback w)))
(when cb (when cb
(msg "adding callback from" (widget-id w))
(add-callback! (callback (widget-id w) (widget-type w) cb))))) (add-callback! (callback (widget-id w) (widget-type w) cb)))))
(update-callbacks! (cdr widget-list))))) (update-callbacks! (cdr widget-list)))))
......
...@@ -18,14 +18,16 @@ ...@@ -18,14 +18,16 @@
;; colours ;; colours
(msg "starting up....")
(define trans-col (list 0 0 0 0)) (define trans-col (list 0 0 0 0))
(define colour-one (list 0 0 255 100))
(define colour-two (list 127 127 255 100))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; persistent database ;; persistent database
(define db "/sdcard/starwisp/local-symbai.db") (define db "/sdcard/symbai/local-symbai.db")
(db-open db) (db-open db)
(setup db "local") (setup db "local")
(setup db "sync") (setup db "sync")
...@@ -57,6 +59,8 @@ ...@@ -57,6 +59,8 @@
(list 'household (list "Household")) (list 'household (list "Household"))
(list 'individual (list "Individual")) (list 'individual (list "Individual"))
(list 'add-item (list "+"))
(list 'default-village-name (list "New village"))
(list 'title (list "Symbai" "Symbai" "Symbai")) (list 'title (list "Symbai" "Symbai" "Symbai"))
(list 'sync (list "Sync" "Sync" "Sync")) (list 'sync (list "Sync" "Sync" "Sync"))
...@@ -67,7 +71,6 @@ ...@@ -67,7 +71,6 @@
(list 'user-id (list "User ID" "User ID" "User ID")) (list 'user-id (list "User ID" "User ID" "User ID"))
(list 'ok (list "Ok" "Ok" "Ok")) (list 'ok (list "Ok" "Ok" "Ok"))
(list 'cancel (list "Cancel" "Cancel" "Cancel")) (list 'cancel (list "Cancel" "Cancel" "Cancel"))
(list 'new-village (list "+" "+" "+"))
(list 'villages (list "Villages" "Villages" "Villages")) (list 'villages (list "Villages" "Villages" "Villages"))
;; village screen ;; village screen
...@@ -211,6 +214,10 @@ ...@@ -211,6 +214,10 @@
(msg "symbol->id: [" id "] is not a symbol")) (msg "symbol->id: [" id "] is not a symbol"))
(make-id (symbol->string id))) (make-id (symbol->string id)))
(define (get-symbol-id id)
(when (not (symbol? id))
(msg "symbol->id: [" id "] is not a symbol"))
(get-id (symbol->string id)))
(define (mbutton id fn) (define (mbutton id fn)
(button (symbol->id id) (button (symbol->id id)
...@@ -257,16 +264,23 @@ ...@@ -257,16 +264,23 @@
(mtext-lookup id) (mtext-lookup id)
50 (layout 'fill-parent 'wrap-content -1 'centre 0))) 50 (layout 'fill-parent 'wrap-content -1 'centre 0)))
(define (mtitle-scale id)
(text-view (symbol->id id)
(mtext-lookup id)
50 (layout 'fill-parent 'wrap-content 1 'centre 0)))
(define (medit-text id type fn) (define (medit-text id type fn)
(vert (vert
(mtext id) (text-view 0 (mtext-lookup id)
30 (layout 'wrap-content 'wrap-content -1 'centre 0))
(edit-text (symbol->id id) "" 30 type (edit-text (symbol->id id) "" 30 type
(layout 'fill-parent 'wrap-content -1 'centre 0) (layout 'fill-parent 'wrap-content -1 'centre 0)
fn))) fn)))
(define (medit-text-scale id type fn) (define (medit-text-scale id type fn)
(vert (vert
(mtext id) (text-view 0 (mtext-lookup id)
30 (layout 'wrap-content 'wrap-content 1 'centre 0))
(edit-text (symbol->id id) "" 30 type (edit-text (symbol->id id) "" 30 type
(layout 'fill-parent 'wrap-content 1 'centre 0) (layout 'fill-parent 'wrap-content 1 'centre 0)
fn))) fn)))
...@@ -312,6 +326,19 @@ ...@@ -312,6 +326,19 @@
r (cons (update-widget 'toggle-button (get-id id) 'checked 0) r))) r (cons (update-widget 'toggle-button (get-id id) 'checked 0) r)))
'() id-list)) '() id-list))
;; fill out the widget from the current entity in the memory store
;; dispatches based on widget type
(define (mupdate widget-type id-symbol key)
(cond
((eq? widget-type 'edit-text)
(update-widget widget-type (get-symbol-id id-symbol) 'text
(entity-get-value key)))
((eq? widget-type 'toggle-button)
(update-widget widget-type (get-symbol-id id-symbol) 'selected
(entity-get-value key)))
(else (msg "mupdate-widget unhandled widget type" widget-type))))
;;;; ;;;;
(define (db-mongooses-by-pack) (define (db-mongooses-by-pack)
...@@ -469,8 +496,21 @@ ...@@ -469,8 +496,21 @@
(layout 'fill-parent 'fill-parent 1 'centre 0) (layout 'fill-parent 'fill-parent 1 'centre 0)
(list 0 0 0 0) (list 0 0 0 0)
(list (list
(mbutton-scale 'cancel (lambda () (list))) (mbutton-scale
(mbutton-scale 'ok (lambda () (list))))) 'ok
(lambda ()
(list
(alert-dialog
"ok-check"
"Are you sure you want to save changes?"
(lambda (v)
(cond
((eqv? v 1)
(entity-update-values!)
(list (finish-activity 1)))
(else
(list))))))))
(mbutton-scale 'cancel (lambda () (list (finish-activity 1))))))
(lambda (fragment arg) (lambda (fragment arg)
(activity-layout fragment)) (activity-layout fragment))
(lambda (fragment arg) (lambda (fragment arg)
...@@ -489,7 +529,7 @@ ...@@ -489,7 +529,7 @@
(vert-fill (vert-fill
(relative (relative
'(("parent-top")) '(("parent-top"))
(list 100 100 255 127) colour-one ;;(list 100 100 255 127)
(build-fragment "top" (make-id "top") fillwrap)) (build-fragment "top" (make-id "top") fillwrap))
(scroll-view-vert (scroll-view-vert
...@@ -499,12 +539,49 @@ ...@@ -499,12 +539,49 @@
(relative (relative
'(("parent-bottom")) '(("parent-bottom"))
(list 100 100 255 127) colour-one
(vert (vert
(spacer 5) (spacer 5)
(build-fragment "bottom" (make-id "bottom") fillwrap))))) (build-fragment "bottom" (make-id "bottom") fillwrap)))))
;; a standard builder for list widgets of entities and a
;; make new button, to add defaults to the list
(define (build-list-widget db table entity-type edit-activity ktv-default)
(vert-colour
colour-two
(horiz
(mtitle-scale 'villages)
(mbutton-scale
'add-item
(lambda ()
(entity-init! db table entity-type ktv-default)
(entity-record-values!)
(list (update-list-widget db table entity-type edit-activity)))))
(linear-layout
(make-id (string-append entity-type "-list"))
'vertical
(layout 'fill-parent 'wrap-content 1 'centre 20)
(list 0 0 0 0)
(list))))
;; pull db data into list of button widgets
(define (update-list-widget db table entity-type edit-activity)
(update-widget
'linear-layout
(get-id (string-append entity-type "-list"))
'contents
(map
(lambda (e)
(button
(make-id (string-append "list-button-" (ktv-get e "unique_id")))
(or (ktv-get e "name") "Unamed item")
40 (layout 'fill-parent 'wrap-content 1 'centre 5)
(lambda ()
(msg "sending start act" (ktv-get e "unique_id"))
(list (start-activity edit-activity 0 (ktv-get e "unique_id"))))))
(db-all db table entity-type))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; activities ;; activities
...@@ -521,18 +598,18 @@ ...@@ -521,18 +598,18 @@
(mbutton-scale 'sync (lambda () (list)))) (mbutton-scale 'sync (lambda () (list))))
(mspinner 'languages (list 'english 'khasi 'hindi) (lambda (c) (list))) (mspinner 'languages (list 'english 'khasi 'hindi) (lambda (c) (list)))
(mtitle 'villages) (build-list-widget db "sync" "village" "village"
(mbutton 'village (lambda () (list (start-activity "village" 0 "")))) (list
(mbutton 'village (lambda () (list (start-activity "village" 0 "")))) (ktv "name" "varchar" (mtext-lookup 'default-village-name))
(mbutton 'village (lambda () (list (start-activity "village" 0 "")))) (ktv "block" "varchar" "")
(mbutton 'village (lambda () (list (start-activity "village" 0 ""))))) (ktv "district" "varchar" "test")
(ktv "car" "int" 0))))
(lambda (activity arg) (lambda (activity arg)
(set-current! 'activity-title "Main screen") (set-current! 'activity-title "Main screen")
(activity-layout activity)) (activity-layout activity))
(lambda (activity arg) (lambda (activity arg)
(list (update-widget (list (update-list-widget db "sync" "village" "village")))
'image-view (get-id "image")
'external-image (string-append dirname "photo.jpg"))))
(lambda (activity) '()) (lambda (activity) '())
(lambda (activity) '()) (lambda (activity) '())
(lambda (activity) '()) (lambda (activity) '())
...@@ -553,7 +630,7 @@ ...@@ -553,7 +630,7 @@
(let ((place-widgets (let ((place-widgets
(lambda (id shade) (lambda (id shade)
(horiz-colour (horiz-colour
(if shade (list 0 0 255 100) (list 127 127 255 100)) (if shade colour-one colour-two)
(mtoggle-button-scale id (lambda (v) '())) (mtoggle-button-scale id (lambda (v) '()))
(medit-text-scale 'closest-access "normal" (lambda (v) '())) (medit-text-scale 'closest-access "normal" (lambda (v) '()))
(vert (vert
...@@ -562,7 +639,8 @@ ...@@ -562,7 +639,8 @@
(mtext-small 'test-num)))))) (mtext-small 'test-num))))))
(build-activity (build-activity
(horiz (horiz
(medit-text 'village-name "normal" (lambda () '())) (medit-text 'village-name "normal"
(lambda (v) (entity-set-value! "name" "varchar" v) '()))
(medit-text 'block "normal" (lambda () '()))) (medit-text 'block "normal" (lambda () '())))
(horiz (horiz
(medit-text 'district "normal" (lambda () '())) (medit-text 'district "normal" (lambda () '()))
...@@ -582,9 +660,15 @@ ...@@ -582,9 +660,15 @@
(set-current! 'activity-title "Village") (set-current! 'activity-title "Village")
(activity-layout activity)) (activity-layout activity))
(lambda (activity arg) (lambda (activity arg)
(let ((user-id (ktv-get (get-entity db "local" 1) "user-id"))) (msg "activity start - entity init")
(set-current! 'user-id user-id) (entity-init! db "sync" "village" (get-entity-by-unique db "sync" arg))
(list))) (msg "activity start - entity init done")
(list
(mupdate 'edit-text 'village-name "name")
(mupdate 'edit-text 'block "block")
(mupdate 'edit-text 'district "district")
(mupdate 'toggle-button 'car "car")
(toast arg)))
(lambda (activity) '()) (lambda (activity) '())
(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