Commit a527726e authored by dave griffiths's avatar dave griffiths
Browse files

Merge branch 'master' of github.com:nebogeo/symbai

parents d7ef0456 02979ce5
<?xml version="1.0" encoding="utf-8"?> <?xml version="1.0" encoding="utf-8"?>
<manifest xmlns:android="http://schemas.android.com/apk/res/android" <manifest xmlns:android="http://schemas.android.com/apk/res/android"
package="foam.symbai" package="foam.symbai"
android:versionCode="2" android:versionCode="3"
android:versionName="1.0"> android:versionName="1.0">
<application android:label="@string/app_name" <application android:label="@string/app_name"
android:icon="@drawable/logo" android:icon="@drawable/logo"
......
...@@ -68,12 +68,20 @@ ...@@ -68,12 +68,20 @@
;; 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)
;; (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! (set-current!
'entity-values 'entity-values
(ktv-set (ktv-set
(get-current 'entity-values '()) (get-current 'entity-values '())
(ktv key type value)))) (ktv-create key type value))))
(define (entity-set! ktv-list) (define (entity-set! ktv-list)
(set-current! 'entity-values ktv-list)) (set-current! 'entity-values ktv-list))
...@@ -83,7 +91,6 @@ ...@@ -83,7 +91,6 @@
;; version to check the entity has the key ;; version to check the entity has the key
(define (entity-set-value! key type value) (define (entity-set-value! key type value)
(msg "entity-set-value!")
(let ((existing-type (ktv-get-type (get-current 'entity-values '()) key))) (let ((existing-type (ktv-get-type (get-current 'entity-values '()) key)))
(if (equal? existing-type type) (if (equal? existing-type type)
(set-current! (set-current!
...@@ -91,8 +98,11 @@ ...@@ -91,8 +98,11 @@
(ktv-set (ktv-set
(get-current 'entity-values '()) (get-current 'entity-values '())
(ktv key type value))) (ktv key type value)))
(msg "entity-set-value -" key "of type" type "doesn't exist on this entity")) ;;
(msg "done entity-set-value!"))) (begin
(msg "entity-set-value! - adding new " key "of type" type "to entity")
(entity-add-value-create! key type value)))))
(define (date-time->string dt) (define (date-time->string dt)
(string-append (string-append
...@@ -109,23 +119,26 @@ ...@@ -109,23 +119,26 @@
(table (get-current 'table #f)) (table (get-current 'table #f))
(type (get-current 'entity-type #f))) (type (get-current 'entity-type #f)))
;; standard bits ;; standard bits
(entity-add-value! "user" "varchar" (get-current 'user-id "none")) (let ((r (entity-create! db table type (get-current 'entity-values '()))))
(entity-add-value! "time" "varchar" (date-time->string (date-time))) (entity-reset!) r)))
(entity-add-value! "lat" "real" (car (get-current 'location '(0 0))))
(entity-add-value! "lon" "real" (cadr (get-current 'location '(0 0))))
(entity-add-value! "deleted" "int" 0) (define (entity-create! db table entity-type ktv-list)
(let ((values (get-current 'entity-values '()))) (let ((values
(cond (append
((not (null? values)) (list
(ktv-create "user" "varchar" (get-current 'user-id "none"))
(ktv-create "time" "varchar" (date-time->string (date-time)))
(ktv-create "lat" "real" (car (get-current 'location '(0 0))))
(ktv-create "lon" "real" (cadr (get-current 'location '(0 0))))
(ktv-create "deleted" "int" 0))
ktv-list)))
(let ((r (insert-entity/get-unique (let ((r (insert-entity/get-unique
db table type (get-current 'user-id "no id") db table entity-type (get-current 'user-id "no id")
values))) values)))
(msg "inserted a " type) (msg "entity-create: " entity-type)
(entity-reset!) r)) r)))
(else
(msg "no values to add as entity!") #f)))
;; just to be on the safe side
(entity-reset!)))
(define (entity-update-values!) (define (entity-update-values!)
(let ((db (get-current 'db #f)) (let ((db (get-current 'db #f))
...@@ -138,7 +151,9 @@ ...@@ -138,7 +151,9 @@
(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)
(msg "updated " unique-id) (msg "updated " unique-id)
(msg values) (msg values)
(entity-reset!)) ;; removed due to save button no longer exiting activity - need to keep!
;;(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))))))
...@@ -164,7 +179,7 @@ ...@@ -164,7 +179,7 @@
(msg "url") (msg "url")
(define (build-url-from-ktv ktv) (define (build-url-from-ktv ktv)
(string-append "&" (ktv-key ktv) ":" (ktv-type ktv) "=" (stringify-value-url ktv))) (string-append "&" (ktv-key ktv) ":" (ktv-type ktv) ":" (number->string (ktv-version ktv)) "=" (stringify-value-url ktv)))
(define (build-url-from-ktvlist ktvlist) (define (build-url-from-ktvlist ktvlist)
(foldl (foldl
...@@ -200,13 +215,12 @@ ...@@ -200,13 +215,12 @@
r)) r))
'() ktvlist)) '() ktvlist))
(msg "spit")
;; spit all dirty entities to server ;; spit all dirty entities to server
(define (spit db table entities) (define (spit db table entities)
(msg "running spit")
(foldl (foldl
(lambda (e r) (lambda (e r)
;;(msg (car (car e)))
(debug! (string-append "Sending a " (car (car e)) " to Raspberry Pi")) (debug! (string-append "Sending a " (car (car e)) " to Raspberry Pi"))
(append (append
(list (list
...@@ -271,6 +285,8 @@ ...@@ -271,6 +285,8 @@
(ktvlist (list-ref data 1)) (ktvlist (list-ref data 1))
(unique-id (list-ref entity 1)) (unique-id (list-ref entity 1))
(exists (entity-exists? db table unique-id))) (exists (entity-exists? db table unique-id)))
(msg "from server...:")
(msg ktvlist)
;; need to check exists again here, due to delays back and forth ;; need to check exists again here, due to delays back and forth
(if (not exists) (if (not exists)
(insert-entity-wholesale (insert-entity-wholesale
...@@ -298,6 +314,7 @@ ...@@ -298,6 +314,7 @@
"new-entities-req" "new-entities-req"
(string-append url "fn=entity-versions&table=" table) (string-append url "fn=entity-versions&table=" table)
(lambda (data) (lambda (data)
(msg "entity-versions:" data)
(let ((r (foldl (let ((r (foldl
(lambda (i r) (lambda (i r)
(let* ((unique-id (car i)) (let* ((unique-id (car i))
...@@ -309,6 +326,13 @@ ...@@ -309,6 +326,13 @@
db table db table
(get-entity-id db table unique-id))) (get-entity-id db table unique-id)))
#f))) #f)))
(msg "suck check entity old=" old)
(msg "version there" version)
(when exists
(msg "version here" (get-entity-version
db table
(get-entity-id db table unique-id))))
;; if we don't have this entity or the version on the server is newer ;; if we don't have this entity or the version on the server is newer
(if (or (not exists) old) (if (or (not exists) old)
(cons (suck-entity-from-server db table unique-id) r) (cons (suck-entity-from-server db table unique-id) r)
...@@ -373,3 +397,329 @@ ...@@ -373,3 +397,329 @@
(list (list
;;(update-widget 'text-view (get-id "sync-connect") 'text state) ;;(update-widget 'text-view (get-id "sync-connect") 'text state)
)))))) ))))))
(define i18n-lang 0)
(define i18n-text
(list))
(msg 123)
(define (mtext-lookup id)
(define (_ l)
(cond
((null? l) (string-append (symbol->string id) " not translated"))
((eq? (car (car l)) id)
(let ((translations (cadr (car l))))
(if (<= (length translations) i18n-lang)
(string-append (symbol->string id) " not translated")
(list-ref translations i18n-lang))))
(else (_ (cdr l)))))
(_ i18n-text))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (symbol->id id)
(when (not (symbol? id))
(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)
(mtext-lookup id)
40 (layout 'fill-parent 'wrap-content -1 'centre 5) fn))
(define (mbutton-scale id fn)
(button (symbol->id id)
(mtext-lookup id)
40 (layout 'fill-parent 'wrap-content 1 'centre 5) fn))
(define (mtoggle-button id fn)
(toggle-button (symbol->id id)
(mtext-lookup id)
30 (layout 'fill-parent 'wrap-content -1 'centre 0) "fancy"
;; convert to 0/1 for easier db storage
(lambda (v) (fn (if v 1 0)))))
(define (mtoggle-button-scale id fn)
(toggle-button (symbol->id id)
(mtext-lookup id)
30 (layout 'fill-parent 'wrap-content 1 'centre 0) "fancy"
(lambda (v) (fn (if v 1 0)))))
(define (mtext id)
(text-view (symbol->id id)
(mtext-lookup id)
30 (layout 'wrap-content 'wrap-content -1 'centre 0)))
(define (mtext-fixed w id)
(text-view (symbol->id id)
(mtext-lookup id)
30 (layout w 'wrap-content -1 'centre 0)))
(define (mtext-small id)
(text-view (symbol->id id)
(mtext-lookup id)
20 (layout 'wrap-content 'wrap-content -1 'centre 0)))
(define (mtext-scale id)
(text-view (symbol->id id)
(mtext-lookup id)
30 (layout 'wrap-content 'wrap-content 1 'centre 0)))
(define (mtitle id)
(text-view (symbol->id id)
(mtext-lookup id)
50 (layout 'fill-parent 'wrap-content -1 'centre 5)))
(define (mtitle-scale id)
(text-view (symbol->id id)
(mtext-lookup id)
50 (layout 'fill-parent 'wrap-content 1 'centre 5)))
(define (medit-text id type fn)
(vert
(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
(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 (mspinner id types fn)
(vert
(text-view (symbol->id id)
(mtext-lookup id)
30 (layout 'wrap-content 'wrap-content 1 'centre 10))
(spinner (make-id (string-append (symbol->string id) "-spinner"))
(map mtext-lookup types)
(layout 'wrap-content 'wrap-content 1 'centre 0)
(lambda (c) (fn c)))))
(define (mspinner-other id types fn)
(horiz
(vert
(text-view (symbol->id id)
(mtext-lookup id)
30 (layout 'wrap-content 'wrap-content 1 'centre 10))
(spinner (make-id (string-append (symbol->string id) "-spinner"))
(map mtext-lookup types)
(layout 'wrap-content 'wrap-content 1 'centre 0)
(lambda (c) (fn c))))
(vert
(mtext-scale 'other)
(edit-text (make-id (string-append (symbol->string id) "-edit-text"))
"" 30 "normal"
(layout 'fill-parent 'wrap-content 1 'centre 0)
(lambda (t) (fn t))))))
(define (mspinner-other-vert id text-id types fn)
(linear-layout
0 'vertical
(layout 'fill-parent 'wrap-content 1 'centre 5)
(list 0 0 0 0)
(list
(text-view (symbol->id id)
(mtext-lookup text-id)
30 (layout 'wrap-content 'wrap-content 1 'centre 5))
(spinner (make-id (string-append (symbol->string id) "-spinner"))
(map mtext-lookup types)
(layout 'wrap-content 'wrap-content 1 'centre 0)
(lambda (c) (fn c)))
(mtext-scale 'other)
(edit-text (make-id (string-append (symbol->string id) "-edit-text"))
"" 30 "normal"
(layout 'fill-parent 'wrap-content 1 'centre 0)
(lambda (t) (fn t))))))
(define (mclear-toggles id-list)
(map
(lambda (id)
(update-widget 'toggle-button (get-id id) 'checked 0))
id-list))
(define (mclear-toggles-not-me me id-list)
(foldl
(lambda (id r)
(if (equal? me id)
r (cons (update-widget 'toggle-button (get-id id) 'checked 0) r)))
'() id-list))
(define (image-invalid? image-name)
(or (null? image-name)
(not image-name)
(equal? image-name "none")))
;; 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
((or (eq? widget-type 'edit-text) (eq? widget-type 'text-view))
(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) 'checked
(entity-get-value key)))
((eq? widget-type 'image-view)
(let ((image-name (entity-get-value key)))
(if (image-invalid? image-name)
(update-widget widget-type (get-symbol-id id-symbol) 'image "face")
(update-widget widget-type (get-symbol-id id-symbol) 'external-image
(string-append dirname "files/" image-name)))))
(else (msg "mupdate-widget unhandled widget type" widget-type))))
(define (mupdate-spinner id-symbol key choices)
(let* ((val (entity-get-value key))
(index (index-find val (map mtext-lookup choices))))
(if index
(update-widget 'spinner
(get-id (string-append (symbol->string id-symbol) "-spinner"))
'selection index)
(begin
(msg "spinner item in db " val " not found in list of items")
(update-widget 'spinner
(get-id (string-append (symbol->string id-symbol) "-spinner"))
'selection 0)))))
(define (mupdate-spinner-other id-symbol key choices)
(msg "update spinner other...")
(let* ((val (entity-get-value key))
(index (index-find val (map mtext-lookup choices))))
(if index
(update-widget 'spinner
(get-id (string-append (symbol->string id-symbol) "-spinner"))
'selection index)
(update-widget 'edit-text
(get-id (string-append (symbol->string id-symbol) "-edit-text"))
'selection index))))
;;;;
;; (y m d h m s)
(define (date-minus-months d ms)
(let ((year (list-ref d 0))
(month (- (list-ref d 1) 1)))
(let ((new-month (- month ms)))
(list
(if (< new-month 0) (- year 1) year)
(+ (if (< new-month 0) (+ new-month 12) new-month) 1)
(list-ref d 2)
(list-ref d 3)
(list-ref d 4)
(list-ref d 5)))))
(define (do-gps display-id key-prepend)
(let ((loc (get-current 'location '(0 0))))
(entity-set-value! (string-append key-prepend "-lat") "real" (car loc))
(entity-set-value! (string-append key-prepend "-lon") "real" (cadr loc))
(list
(update-widget
'text-view
(get-id (string-append (symbol->string display-id) "-lat"))
'text
(number->string (car loc)))
(update-widget
'text-view
(get-id (string-append (symbol->string display-id) "-lon"))
'text
(number->string (cadr loc))))))
(define (mupdate-gps display-id key-prepend)
(let ((lat (entity-get-value (string-append key-prepend "-lat")))
(lon (entity-get-value (string-append key-prepend "-lon"))))
(if (or (not lat) (not lon))
(list
(update-widget
'text-view (get-id (string-append (symbol->string display-id) "-lat"))
'text "O")
(update-widget
'text-view (get-id (string-append (symbol->string display-id) "-lon"))
'text "0"))
(list
(update-widget
'text-view (get-id (string-append (symbol->string display-id) "-lat"))
'text (number->string lat))
(update-widget
'text-view (get-id (string-append (symbol->string display-id) "-lon"))
'text (number->string lon))))))
;; 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 title entity-type edit-activity parent-fn ktv-default)
(vert-colour
colour-two
(horiz
(mtitle-scale title)
(button
(make-id (string-append (symbol->string title) "-add"))
(mtext-lookup 'add-item-to-list)
40 (layout 100 'wrap-content 1 'centre 5)
(lambda ()
(entity-create!
db table entity-type
(ktvlist-merge
ktv-default
(list (ktv "parent" "varchar" (parent-fn)))))
(list (update-list-widget db table entity-type edit-activity (parent-fn))))))
(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 parent)
(let ((search-results
(if parent
(db-with-parent db table entity-type parent)
(db-all db table entity-type))))
(update-widget
'linear-layout
(get-id (string-append entity-type "-list"))
'contents
(if (null? search-results)
(list (mtext 'list-empty))
(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"))))))
search-results)))))
(define (delete-button)
(mbutton
'delete
(lambda ()
(list
(alert-dialog
"delete-check"
(mtext-lookup 'delete-are-you-sure)
(lambda (v)
(cond
((eqv? v 1)
(entity-set-value! "deleted" "int" 1)
(entity-update-values!)
(list (finish-activity 1)))
(else
(list)))))))))
...@@ -27,23 +27,59 @@ ...@@ -27,23 +27,59 @@
;; entity-attribut-value system for sqlite ;; entity-attribut-value system for sqlite
;; ;;
;; create eav tables (add types as required) ;; create eav tables (add types as required)
(define (setup db table) (define (setup db table)
(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)")) (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_int ( id integer primary key autoincrement, entity_id integer, attribute_id varchar(255), value integer, dirty 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)"))
(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)")) (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)"))) (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)")))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; basic key/type/value structure ;; basic key/type/value structure
(define (ktv key type value) (list key type value)) ;; used for all data internally, and maps to the eavdb types
(define (ktv key type value) (list key type value -999))
(define (ktv-with-version key type value version) (list key type value version))
(define (ktv-create key type value) (list key type value 0))
(define ktv-key car) (define ktv-key car)
(define ktv-type cadr) (define ktv-type cadr)
(define ktv-value caddr) (define ktv-value caddr)
(define (ktv-version ktv) (list-ref ktv 3))
(define (ktv-eq? a b)
(and
(equal? (ktv-key a) (ktv-key b))
(equal? (ktv-type a) (ktv-type b))
(cond
((or
(equal? (ktv-type a) "int")
(equal? (ktv-type a) "real"))
(eqv? (ktv-value a) (ktv-value b)))
((or
(equal? (ktv-type a) "varchar")
(equal? (ktv-type a) "file"))