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 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; db abstraction
(define (entity-init! ktv-list)
(define (entity-init! db table entity-type ktv-list)
(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
(define (entity-add-value! key type value)
......@@ -73,47 +77,73 @@
(define (entity-set! 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)
(string-append
(number->string (list-ref dt 0)) "-"
(number->string (list-ref dt 1)) "-"
(number->string (list-ref dt 2)) " "
(number->string (list-ref dt 3)) ":"
(number->string (list-ref dt 4)) ":"
(substring (number->string (+ 100 (list-ref dt 5))) 1 2)))
(substring (number->string (+ (list-ref dt 1) 100)) 1 3) "-"
(substring (number->string (+ (list-ref dt 2) 100)) 1 3) " "
(substring (number->string (+ (list-ref dt 3) 100)) 1 3) ":"
(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
(define (entity-record-values db table type)
;; standard bits
(entity-add-value! "user" "varchar" (get-current 'user-id "none"))
(entity-add-value! "time" "varchar" (date-time->string (date-time)))
(entity-add-value! "lat" "real" (car (get-current 'location '(0 0))))
(entity-add-value! "lon" "real" (cadr (get-current 'location '(0 0))))
(let ((values (get-current 'entity-values '())))
(cond
((not (null? values))
(let ((r (insert-entity/get-unique
db table type (get-current 'user-id "no id")
values)))
(msg "inserted a " type)
(entity-reset!) r))
(else
(msg "no values to add as entity!") #f))))
(define (entity-update-values db table)
;; standard bits
(let ((values (get-current 'entity-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-record-values!)
(let ((db (get-current 'db #f))
(table (get-current 'table #f))
(type (get-current 'entity-type #f)))
;; standard bits
(entity-add-value! "user" "varchar" (get-current 'user-id "none"))
(entity-add-value! "time" "varchar" (date-time->string (date-time)))
(entity-add-value! "lat" "real" (car (get-current 'location '(0 0))))
(entity-add-value! "lon" "real" (cadr (get-current 'location '(0 0))))
(let ((values (get-current 'entity-values '())))
(cond
((not (null? values))
(let ((r (insert-entity/get-unique
db table type (get-current 'user-id "no id")
values)))
(msg "inserted a " type)
(entity-reset!) r))
(else
(msg "no values to add as entity!") #f)))
;; just to be on the safe side
(entity-reset!)))
(define (entity-update-values!)
(let ((db (get-current 'db #f))
(table (get-current 'table #f)))
;; standard bits
(let ((values (get-current 'entity-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!)
(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)
(foldl
......
......@@ -358,6 +358,13 @@
(ktv-value (car ktv-list)))
(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)
(cond
((null? ktv-list) (list ktv))
......@@ -609,8 +616,11 @@
"select entity_id from " table "_entity where 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)
(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)
(foldl
......
......@@ -640,6 +640,13 @@
(list 0 0 0 0)
l))
(define (vert-colour col . l)
(linear-layout
0 'vertical
(layout 'fill-parent 'wrap-content 1 'centre 20)
col
l))
(define (vert-fill . l)
(linear-layout
0 'vertical
......@@ -725,7 +732,6 @@
(update-callbacks! c))
(let ((cb (widget-get-callback w)))
(when cb
(msg "adding callback from" (widget-id w))
(add-callback! (callback (widget-id w) (widget-type w) cb)))))
(update-callbacks! (cdr widget-list)))))
......
......@@ -18,14 +18,16 @@
;; colours
(msg "starting up....")
(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
(define db "/sdcard/starwisp/local-symbai.db")
(define db "/sdcard/symbai/local-symbai.db")
(db-open db)
(setup db "local")
(setup db "sync")
......@@ -57,6 +59,8 @@
(list 'household (list "Household"))
(list 'individual (list "Individual"))
(list 'add-item (list "+"))
(list 'default-village-name (list "New village"))
(list 'title (list "Symbai" "Symbai" "Symbai"))
(list 'sync (list "Sync" "Sync" "Sync"))
......@@ -67,7 +71,6 @@
(list 'user-id (list "User ID" "User ID" "User ID"))
(list 'ok (list "Ok" "Ok" "Ok"))
(list 'cancel (list "Cancel" "Cancel" "Cancel"))
(list 'new-village (list "+" "+" "+"))
(list 'villages (list "Villages" "Villages" "Villages"))
;; village screen
......@@ -211,6 +214,10 @@
(msg "symbol->id: [" id "] is not a symbol"))
(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)
(button (symbol->id id)
......@@ -257,16 +264,23 @@
(mtext-lookup id)
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)
(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
(layout 'fill-parent 'wrap-content -1 'centre 0)
fn)))
(define (medit-text-scale id type fn)
(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
(layout 'fill-parent 'wrap-content 1 'centre 0)
fn)))
......@@ -312,6 +326,19 @@
r (cons (update-widget 'toggle-button (get-id id) 'checked 0) r)))
'() 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)
......@@ -469,8 +496,21 @@
(layout 'fill-parent 'fill-parent 1 'centre 0)
(list 0 0 0 0)
(list
(mbutton-scale 'cancel (lambda () (list)))
(mbutton-scale 'ok (lambda () (list)))))
(mbutton-scale
'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)
(activity-layout fragment))
(lambda (fragment arg)
......@@ -489,7 +529,7 @@
(vert-fill
(relative
'(("parent-top"))
(list 100 100 255 127)
colour-one ;;(list 100 100 255 127)
(build-fragment "top" (make-id "top") fillwrap))
(scroll-view-vert
......@@ -499,12 +539,49 @@
(relative
'(("parent-bottom"))
(list 100 100 255 127)
colour-one
(vert
(spacer 5)
(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
......@@ -521,18 +598,18 @@
(mbutton-scale 'sync (lambda () (list))))
(mspinner 'languages (list 'english 'khasi 'hindi) (lambda (c) (list)))
(mtitle 'villages)
(mbutton 'village (lambda () (list (start-activity "village" 0 ""))))
(mbutton 'village (lambda () (list (start-activity "village" 0 ""))))
(mbutton 'village (lambda () (list (start-activity "village" 0 ""))))
(mbutton 'village (lambda () (list (start-activity "village" 0 "")))))
(build-list-widget db "sync" "village" "village"
(list
(ktv "name" "varchar" (mtext-lookup 'default-village-name))
(ktv "block" "varchar" "")
(ktv "district" "varchar" "test")
(ktv "car" "int" 0))))
(lambda (activity arg)
(set-current! 'activity-title "Main screen")
(activity-layout activity))
(lambda (activity arg)
(list (update-widget
'image-view (get-id "image")
'external-image (string-append dirname "photo.jpg"))))
(list (update-list-widget db "sync" "village" "village")))
(lambda (activity) '())
(lambda (activity) '())
(lambda (activity) '())
......@@ -553,7 +630,7 @@
(let ((place-widgets
(lambda (id shade)
(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) '()))
(medit-text-scale 'closest-access "normal" (lambda (v) '()))
(vert
......@@ -562,7 +639,8 @@
(mtext-small 'test-num))))))
(build-activity
(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 () '())))
(horiz
(medit-text 'district "normal" (lambda () '()))
......@@ -582,9 +660,15 @@
(set-current! 'activity-title "Village")
(activity-layout activity))
(lambda (activity arg)
(let ((user-id (ktv-get (get-entity db "local" 1) "user-id")))
(set-current! 'user-id user-id)
(list)))
(msg "activity start - entity init")
(entity-init! db "sync" "village" (get-entity-by-unique db "sync" arg))
(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) '())
......
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