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"?>
<manifest xmlns:android="http://schemas.android.com/apk/res/android"
package="foam.symbai"
android:versionCode="2"
android:versionCode="3"
android:versionName="1.0">
<application android:label="@string/app_name"
android:icon="@drawable/logo"
......
......@@ -68,12 +68,20 @@
;; 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!
'entity-values
(ktv-set
(get-current 'entity-values '())
(ktv key type value))))
(ktv-create key type value))))
(define (entity-set! ktv-list)
(set-current! 'entity-values ktv-list))
......@@ -83,7 +91,6 @@
;; 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!
......@@ -91,8 +98,11 @@
(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!")))
;;
(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)
(string-append
......@@ -109,23 +119,26 @@
(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))))
(entity-add-value! "deleted" "int" 0)
(let ((values (get-current 'entity-values '())))
(cond
((not (null? values))
(let ((r (entity-create! db table type (get-current 'entity-values '()))))
(entity-reset!) r)))
(define (entity-create! db table entity-type ktv-list)
(let ((values
(append
(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
db table type (get-current 'user-id "no id")
db table entity-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!)))
(msg "entity-create: " entity-type)
r)))
(define (entity-update-values!)
(let ((db (get-current 'db #f))
......@@ -138,7 +151,9 @@
(update-entity db table (entity-id-from-unique db table unique-id) values)
(msg "updated " unique-id)
(msg values)
(entity-reset!))
;; removed due to save button no longer exiting activity - need to keep!
;;(entity-reset!)
)
(else
(msg "no values or no id to update as entity:" unique-id "values:" values))))))
......@@ -164,7 +179,7 @@
(msg "url")
(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)
(foldl
......@@ -200,13 +215,12 @@
r))
'() ktvlist))
(msg "spit")
;; spit all dirty entities to server
(define (spit db table entities)
(msg "running spit")
(foldl
(lambda (e r)
;;(msg (car (car e)))
(debug! (string-append "Sending a " (car (car e)) " to Raspberry Pi"))
(append
(list
......@@ -271,6 +285,8 @@
(ktvlist (list-ref data 1))
(unique-id (list-ref entity 1))
(exists (entity-exists? db table unique-id)))
(msg "from server...:")
(msg ktvlist)
;; need to check exists again here, due to delays back and forth
(if (not exists)
(insert-entity-wholesale
......@@ -298,6 +314,7 @@
"new-entities-req"
(string-append url "fn=entity-versions&table=" table)
(lambda (data)
(msg "entity-versions:" data)
(let ((r (foldl
(lambda (i r)
(let* ((unique-id (car i))
......@@ -309,6 +326,13 @@
db table
(get-entity-id db table unique-id)))
#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 (or (not exists) old)
(cons (suck-entity-from-server db table unique-id) r)
......@@ -373,3 +397,329 @@
(list
;;(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 @@
;; entity-attribut-value system for sqlite
;;
;; create eav tables (add types as required)
(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 "_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_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_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_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_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, 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)")))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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-type cadr)
(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"))
(equal? (ktv-value a) (ktv-value b)))
(else
(msg "unsupported ktv type in ktv-eq?: " (ktv-type a))
#f))))
;; replace or insert a ktv
(define (ktvlist-replace ktv ktvlist)
(cond
((null? ktvlist)
(list ktv))
((equal? (ktv-key (car ktvlist)) (ktv-key ktv))
(cons ktv (cdr ktvlist)))
(else (cons (car ktvlist) (ktvlist-replace ktv (cdr ktvlist))))))
(define (ktvlist-merge a b)
(foldl
(lambda (ktv r)
(ktvlist-replace ktv r))
a b))
;; stringify based on type (for url)
(define (stringify-value ktv)
......@@ -65,6 +101,7 @@
(number->string (ktv-value ktv))
(ktv-value ktv)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; helper to return first instance from a select
(define (select-first db str . args)
......@@ -105,11 +142,11 @@
type))))))
;; low level insert of a ktv
(define (insert-value db table entity-id ktv)
(define (insert-value db table entity-id ktv dirty)
;; use type to dispatch insert to correct value table
(db-insert db (string-append "insert into " table "_value_" (ktv-type ktv)
" values (null, ?, ?, ?, 0)")
entity-id (ktv-key ktv) (ktv-value ktv)))
" values (null, ?, ?, ?, ?, ?)")
entity-id (ktv-key ktv) (ktv-value ktv) (if dirty 1 0) (ktv-version ktv)))
(define (get-unique user)
(let ((t (time-of-day)))
......@@ -140,23 +177,45 @@
;; add all the keys
(for-each
(lambda (ktv)
(insert-value db table id ktv))
(insert-value db table id ktv dirty))
ktvlist)
id))
;; update the value given an entity type, a attribute type and it's key (= attriute_id)
;; creates the value if it doesn't already exist, updates it otherwise
;; creates the value if it doesn't already exist, updates it otherwise if it's different
(define (update-value db table entity-id ktv)
(if (null? (select-first
(msg "update-value")
(let ((s (select-first
db (string-append
"select value from " table "_value_" (ktv-type ktv) " where entity_id = ? and attribute_id = ?")
entity-id (ktv-key ktv))))
(if (null? s)
(insert-value db table entity-id ktv #t)
;; only update if they are different