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

android/AndroidManifest.xml

 <?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"

android/assets/dbsync.scm

@@ -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 (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!)))
+    (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 entity-type (get-current 'user-id "no id")
+              values)))
+      (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)))))))))

android/assets/eavdb.scm

@@ -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
-              db (string-append
-                  "select * from " table "_value_" (ktv-type ktv) " where entity_id = ? and attribute_id = ?")
-              entity-id (ktv-key ktv)))
-      (insert-value db table entity-id ktv)
-      (db-exec
-       db (string-append "update " table "_value_" (ktv-type ktv)
-                         " set value=?  where entity_id = ? and attribute_id = ?")