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

android/assets/dbsync.scm

@@ -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

android/assets/eavdb.scm

@@ -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

android/assets/lib.scm

@@ -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)))))
 

android/assets/starwisp.scm

@@ -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) '())