big sync fixed

android/assets/dbsync.scm

@@ -334,7 +334,9 @@
                                                (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)
+                    (if (and (or (not exists) old)
+                             ;; limit this to 5 a time
+                             (< (length r) 5))
                         (cons (suck-entity-from-server db table unique-id) r)
                         r)))
                 '()
@@ -723,3 +725,197 @@
            (list (finish-activity 1)))
           (else
            (list)))))))))
+
+(define vowel (map symbol->string (list 'a 'e 'i 'o 'u)))
+(define consonant (map symbol->string (list 'b 'c 'd 'f 'g 'h 'j 'k 'l 'm 'n 'p 'q 'r 's 't 'v 'w 'x 'y 'z)))
+
+(define (word-gen)
+  (define (_ s vowel-prob)
+    (cond
+     ((zero? s) '())
+     ((< (random) vowel-prob)
+      (cons (choose vowel) (_ (- s 1) (/ vowel-prob 2))))
+     (else
+      (cons (choose consonant) (_ (- s 1) (* vowel-prob 2))))))
+  (apply string-append (_ (+ 3 (random-int 8)) 0.5)))
+
+
+
+(define (simpsons-village db table default-ktvlist)
+  (entity-create! db table "village"
+                  (ktvlist-merge
+                   default-ktvlist
+                   (list
+                    (ktv "name" "varchar" (word-gen))
+                    (ktv "block" "varchar" (word-gen))
+                    (ktv "district" "varchar" (word-gen))
+                    (ktv "car" "int" (random-int 2))))))
+
+(define (simpsons-household db table parent default-ktvlist)
+  (entity-create! db table "household"
+                  (ktvlist-merge
+                   default-ktvlist
+                   (list
+                    (ktv "name" "varchar" (word-gen))
+                    (ktv "num-pots" "int" (random-int 10))
+                    (ktv "parent" "varchar" parent)))))
+
+(define (simpsons-individual db table parent default-ktvlist)
+  (let ((n (random-int 1000)))
+  (entity-create! db table "individual"
+                  (ktvlist-merge
+                   default-ktvlist
+                   (append
+                    (list (ktv "parent" "varchar" parent))
+  (choose
+   (list
+   (list
+    (ktv-create "name" "varchar"
+                (string-append "Abe-" (number->string n)))
+    (ktv-create "gender" "varchar" "Male")
+    (ktv-create "photo" "file" "abe.jpg"))
+   (list
+    (ktv-create
+     "name" "varchar" (string-append "Akira-" (number->string n)))
+    (ktv-create "gender" "varchar" "Male")
+    (ktv-create "photo" "file" "akira.jpg"))
+   (list
+    (ktv-create
+     "name" "varchar" (string-append "Apu-" (number->string n)))
+    (ktv-create "gender" "varchar" "Male")
+    (ktv-create "photo" "file" "apu.jpg"))
+   (list
+    (ktv-create
+     "name" "varchar" (string-append "Barney-" (number->string n)))
+    (ktv-create "gender" "varchar" "Male")
+    (ktv-create "photo" "file" "barney.jpg"))
+   (list
+    (ktv-create
+     "name" "varchar" (string-append "Bart-" (number->string n)))
+    (ktv-create "gender" "varchar" "Male")
+    (ktv-create "photo" "file" "bartsimpson.jpg"))
+   (list
+    (ktv-create
+     "name" "varchar" (string-append "Billy-" (number->string n)))
+    (ktv-create "gender" "varchar" "Male")
+    (ktv-create "photo" "file" "billy.jpg"))
+   (list
+    (ktv-create
+     "name" "varchar" (string-append "Carl-" (number->string n)))
+    (ktv-create "gender" "varchar" "Male")
+    (ktv-create "photo" "file" "carl.jpg"))
+   (list
+    (ktv-create
+     "name" "varchar" (string-append "Cletus-" (number->string n)))
+    (ktv-create "gender" "varchar" "Male")
+    (ktv-create "photo" "file" "cletus.jpg"))
+   (list
+    (ktv-create
+     "name" "varchar" (string-append "ComicBookGuy-" (number->string n)))
+    (ktv-create "gender" "varchar" "Male")
+    (ktv-create "photo" "file" "comicbookguy.jpg"))
+   (list
+    (ktv-create
+     "name" "varchar" (string-append "Homer-" (number->string n)))
+    (ktv-create "gender" "varchar" "Male")
+    (ktv-create "photo" "file" "homersimpson.jpg"))
+   (list
+    (ktv-create
+     "name" "varchar" (string-append "Jasper-" (number->string n)))
+    (ktv-create "gender" "varchar" "Male")
+    (ktv-create "photo" "file" "jasper.jpg"))
+   (list
+    (ktv-create
+     "name" "varchar" (string-append "Kent-" (number->string n)))
+    (ktv-create "gender" "varchar" "Male")
+    (ktv-create "photo" "file" "kentbrockman.jpg"))
+   (list
+    (ktv-create
+     "name" "varchar" (string-append "Kodos-" (number->string n)))
+    (ktv-create "gender" "varchar" "Male")
+    (ktv-create "photo" "file" "kodos.jpg"))
+   (list
+    (ktv-create
+     "name" "varchar" (string-append "Lenny-" (number->string n)))
+    (ktv-create "gender" "varchar" "Male")
+    (ktv-create "photo" "file" "lenny.jpg"))
+   (list
+    (ktv-create
+     "name" "varchar" (string-append "Lisa-" (number->string n)))
+    (ktv-create "gender" "varchar" "Female")
+    (ktv-create "photo" "file" "lisasimpson.jpg"))
+   (list
+    (ktv-create
+     "name" "varchar" (string-append "Marge-" (number->string n)))
+    (ktv-create "gender" "varchar" "Female")
+    (ktv-create "photo" "file" "margesimpson.jpg"))
+   (list
+    (ktv-create
+     "name" "varchar" (string-append "Martin-" (number->string n)))
+    (ktv-create "gender" "varchar" "Male")
+    (ktv-create "photo" "file" "martinprince.jpg"))
+   (list
+    (ktv-create
+     "name" "varchar" (string-append "Milhouse-" (number->string n)))
+    (ktv-create "gender" "varchar" "Male")
+    (ktv-create "photo" "file" "milhouse.jpg"))
+   (list
+    (ktv-create
+     "name" "varchar" (string-append "MrBurns-" (number->string n)))
+    (ktv-create "gender" "varchar" "Male")
+    (ktv-create "photo" "file" "mrburns.jpg"))
+   (list
+    (ktv-create
+     "name" "varchar" (string-append "Ned-" (number->string n)))
+    (ktv-create "gender" "varchar" "Male")
+    (ktv-create "photo" "file" "nedflanders.jpg"))
+   (list
+    (ktv-create
+     "name" "varchar" (string-append "Nelson-" (number->string n)))
+    (ktv-create "gender" "varchar" "Male")
+    (ktv-create "photo" "file" "nelson.jpg"))
+   (list
+    (ktv-create
+     "name" "varchar" (string-append "Otto-" (number->string n)))
+    (ktv-create "gender" "varchar" "Male")
+    (ktv-create "photo" "file" "otto.jpg"))
+   (list
+    (ktv-create
+     "name" "varchar" (string-append "Ralph-" (number->string n)))
+    (ktv-create "gender" "varchar" "Male")
+    (ktv-create "photo" "file" "ralphwiggum.jpg"))
+   (list
+    (ktv-create
+     "name" "varchar" (string-append "Santaslittlehelper-" (number->string n)))
+    (ktv-create "gender" "varchar" "Male")
+    (ktv-create "photo" "file" "santaslittlehelper.jpg"))
+   (list
+    (ktv-create
+     "name" "varchar" (string-append "SideshowBob-" (number->string n)))
+    (ktv-create "gender" "varchar" "Male")
+    (ktv-create "photo" "file" "sideshowbob.jpg")))))))))
+
+(define (looper! n fn)
+  (when (not (zero? n))
+        (fn n)
+        (looper! (- n 1) fn)))
+
+(msg (random-int 100))
+
+(define (build-test! db table village-ktvlist household-ktvlist individual-ktvlist)
+  (looper!
+   3
+   (lambda (i)
+     (msg "making village" i)
+     (let ((village (simpsons-village db table village-ktvlist)))
+       (looper!
+        8
+        (lambda (i)
+          (alog "household")
+          (msg "making household" i)
+          (let ((household (simpsons-household db table village household-ktvlist)))
+            (looper!
+             (random-int 30)
+             (lambda (i)
+               (msg "making individual" i)
+               (simpsons-individual db table household individual-ktvlist))))))))))

android/assets/eavdb.scm

@@ -185,7 +185,6 @@
 ;; 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 if it's different
 (define (update-value db table entity-id ktv)
-  (msg "update-value")
   (let ((s (select-first
             db (string-append
 				"select value from " table "_value_" (ktv-type ktv) " where entity_id = ? and attribute_id = ?")
@@ -195,7 +194,6 @@
         ;; only update if they are different
         (if (not (ktv-eq? ktv (list (ktv-key ktv) (ktv-type ktv) s)))
             (begin
-              (msg "incrementing value version in update-value")
               (db-exec
                db (string-append "update " table "_value_" (ktv-type ktv)
                                  " set value=?, dirty=1, version=version+1  where entity_id = ? and attribute_id = ?")
@@ -211,7 +209,7 @@
     (if (null? s)
         (insert-value db table entity-id ktv #t)
         (begin
-          (msg "actually updating (fs)" (ktv-key ktv) "to" (ktv-value ktv))
+          ;;(msg "actually updating (fs)" (ktv-key ktv) "to" (ktv-value ktv))
           (db-exec
            db (string-append "update " table "_value_" (ktv-type ktv)
                              " set value=?, dirty=0, version=? where entity_id = ? and attribute_id = ?")
@@ -270,7 +268,7 @@
 		  (let ((vdv (get-value db table entity-id kt)))
 			(if (null? vdv)
 				(begin
-                  (msg "ERROR: get-entity-plain: no value found for " entity-id " " (ktv-key kt))
+                  ;;(msg "ERROR: get-entity-plain: no value found for " entity-id " " (ktv-key kt))
                   r)
 				(cons (list (ktv-key kt) (ktv-type kt)
                             (list-ref vdv 0) (list-ref vdv 2)) r))))
@@ -279,23 +277,19 @@
 
 ;; get an entire entity, as a list of key/value pairs, only dirty values
 (define (get-entity-plain-for-sync db table entity-id)
-  (msg "gepfs")
   (let* ((entity-type (get-entity-type db table entity-id)))
     (cond
       ((null? entity-type) (msg "entity" entity-id "not found!") '())
       (else
        (foldl
         (lambda (kt r)
-          (msg kt)
           (let ((vdv (get-value db table entity-id kt)))
-            (msg vdv)
             (cond
 			 ((null? vdv)
-			  (msg "ERROR: get-entity-plain-for-sync: no value found for " entity-id " " (ktv-key kt))
+			  ;;(msg "ERROR: get-entity-plain-for-sync: no value found for " entity-id " " (ktv-key kt))
 			  r)
 			 ;; only return if dirty
 			 ((not (zero? (cadr vdv)))
-			  (msg "value-dirty-version found" vdv)
 			  (cons
 			   (list (ktv-key kt) (ktv-type kt) (list-ref vdv 0) (list-ref vdv 2))
 			   r))
@@ -310,6 +304,24 @@
      (list "unique_id" "varchar" unique-id)
      (get-entity-plain db table entity-id))))
 
+;; like get-entity-plain, but only look for specific key/types - for speed
+(define (get-entity-only db table entity-id kt-list)
+  (let ((unique-id (get-unique-id db table entity-id)))
+    (cons
+     (list "unique_id" "varchar" unique-id)
+     (foldl
+      (lambda (kt r)
+        (let ((vdv (get-value db table entity-id kt)))
+          (if (null? vdv)
+              (begin
+                ;;(msg "ERROR: get-entity-plain: no value found for " entity-id " " (ktv-key kt))
+                r)
+              (cons (list (ktv-key kt) (ktv-type kt)
+                          (list-ref vdv 0) (list-ref vdv 2)) r))))
+      '()
+      kt-list))))
+
+
 (define (all-entities db table type)
   (let ((s (db-select
             db (string-append "select e.entity_id from " table "_entity as e "
@@ -468,6 +480,13 @@
      (get-entity db table i))
    (filter-entities db table type filter)))
 
+;; only return name and photo
+(define (db-filter-only db table type filter kt-list)
+  (map
+   (lambda (i)
+     (get-entity-only db table i kt-list))
+   (filter-entities db table type filter)))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; updating data
 
@@ -479,7 +498,6 @@
 
 ;; auto update version
 (define (update-entity db table entity-id ktvlist)
-  (msg "update-entity")
   ;; dirty
   (update-entity-changed db table entity-id)
   (update-entity-values db table entity-id ktvlist #t))
@@ -490,7 +508,6 @@
            entity-id (ktv-key kt)))
 
 (define (clean-entity-values db table entity-id)
-  (msg "clean-entity-values")
   (let* ((entity-type (get-entity-type db table entity-id)))
     (cond
      ((null? entity-type)
@@ -498,14 +515,13 @@
      (else
       (for-each
        (lambda (kt)
-         (msg "cleaning" kt)
          (clean-value db table entity-id (list (ktv-key kt) (ktv-type kt))))
        (get-attribute-ids/types db table entity-type))))))
 
 ;; update an entity, via a (possibly partial) list of key/value pairs
 ;; if dirty is not true, this is coming from a sync
 (define (update-entity-values db table entity-id ktvlist dirty)
-  (msg "update-entity-values")
+  ;;(msg "update-entity-values")
   (let* ((entity-type (get-entity-type db table entity-id)))
     (cond
      ((null? entity-type) (msg "entity" entity-id "not found!") '())
@@ -568,15 +584,21 @@
    version entity-id))
 
 (define (update-entity-clean db table unique-id)
-  (msg "cleaning")
+  ;;(msg "cleaning")
   ;; clean entity table
   (db-exec
    db (string-append "update " table "_entity set dirty=? where unique_id = ?")
    0 unique-id)
   ;; clean value tables for this entity
-  (msg "cleaning values")
+  ;;(msg "cleaning values")
   (clean-entity-values db table (entity-id-from-unique db table unique-id))  )
 
+(define (have-dirty? db table)
+  (not (zero?
+        (select-first
+         db (string-append "select count(entity_id) from " table "_entity where dirty=1")))))
+
+
 (define (get-dirty-stats db table)
   (list
    (select-first
@@ -589,17 +611,18 @@
 (define (dirty-entities db table)
   (let ((de (db-select
              db (string-append
-                 "select entity_id, entity_type, unique_id, dirty, version from " table "_entity where dirty=1;"))))
+                 "select entity_id, entity_type, unique_id, dirty, version from "
+                 table "_entity where dirty=1 limit 5;"))))
+    (msg de)
     (if (null? de)
         '()
         (map
          (lambda (i)
-           (msg "dirty-entities")
+           (msg "dirty:" (vector-ref i 2))
            (list
             ;; build according to url ([table] entity-type unique-id dirty version)
             (cdr (vector->list i))
-            ;; data entries (todo - only dirty values!)
-            (dbg (get-entity-plain-for-sync db table (vector-ref i 0)))))
+            (get-entity-plain-for-sync db table (vector-ref i 0))))
          (cdr de)))))
 
 ;; todo: BROKEN...

android/assets/lib.scm

@@ -269,6 +269,9 @@
 (define random
   (random-maker 19781116))  ;; another arbitrarily chosen birthday
 
+(define (random-int n)
+  (abs (random n)))
+
 (define rndf random)
 
 (define (rndvec) (vector (rndf) (rndf) (rndf)))

android/assets/starwisp.scm

@@ -303,9 +303,24 @@
    (list 'weekly (list "Weekly"))
    (list 'monthly (list "Monthly"))
    (list 'less (list "Less"))
-
    ))
 
+(define village-ktvlist
+  (list
+   (ktv-create "name" "varchar" (mtext-lookup 'default-village-name))
+   (ktv-create "block" "varchar" "")
+   (ktv-create "district" "varchar" "test")
+   (ktv-create "car" "int" 0)))
+
+(define household-ktvlist
+  (list
+   (ktv-create "name" "varchar" (mtext-lookup 'default-household-name))
+   (ktv-create "num-pots" "int" 0)
+   (ktv-create "house-lat" "real" 0) ;; get from current location?
+   (ktv-create "house-lon" "real" 0)
+   (ktv-create "toilet-lat" "real" 0)
+   (ktv-create "toilet-lon" "real" 0)))
+
 (define individual-ktvlist
   (list
    (ktv-create "name" "varchar" (mtext-lookup 'default-individual-name))
@@ -371,10 +386,10 @@
         (append
          (list (toast "sync-cb"))
          (upload-dirty db)
-         (suck-new db "sync")))))
+         (if (have-dirty? db "sync") '() (suck-new db "sync"))))))
     (else '()))
    (list
-    (delayed "debug-timer" (+ 10000 (random 5000)) debug-timer-cb)
+    (delayed "debug-timer" (+ 30000 (random 5000)) debug-timer-cb)
     (update-debug))))
 
 
@@ -544,40 +559,61 @@
 
 
 (define (update-individual-filter)
-  (update-widget
-   'linear-layout (get-id "choose-pics") 'contents
-   (grid-ify
-    (map
-     (lambda (e)
-       (let* ((id (ktv-get e "unique_id"))
-              (image-name (ktv-get e "photo"))
-              (image (if (image-invalid? image-name)
-                         "face" (string-append "/sdcard/symbai/files/" image-name))))
-         (if (equal? image "face")
+  (let ((search (db-filter-only db "sync" "individual" (filter-get)
+                                (list
+                                 (list "photo" "file")
+                                 (list "name" "varchar")))))
+    (update-widget
+     'linear-layout (get-id "choose-pics") 'contents
+     (grid-ify
+      (map
+       (lambda (e)
+         (let* ((id (ktv-get e "unique_id"))
+                (image-name (ktv-get e "photo"))
+                (image (if (image-invalid? image-name)
+                           "face" (string-append "/sdcard/symbai/files/" image-name))))
+           (cond
+            ((> (length search) 50)
              (button
               (make-id (string-append "chooser-" id))
-              (ktv-get e "name") 30 (layout (car button-size) (cadr button-size) 1 'centre 5)
+              (ktv-get e "name") 30 (layout (car button-size) (/ (cadr button-size) 3) 1 'centre 5)
               (lambda ()
                 (set-current! 'choose-result id)
-                (list (finish-activity 0))))
-             (image-button
+                (list (finish-activity 0)))))
+
+            ((equal? image "face")
+             (button
               (make-id (string-append "chooser-" id))
-              image (layout (car button-size) (cadr button-size) 1 'centre 5)
+              (ktv-get e "name") 30 (layout (car button-size) (cadr button-size) 1 'centre 5)
               (lambda ()
                 (set-current! 'choose-result id)
-                (list (finish-activity 0)))))))
-     (db-filter db "sync" "individual" (filter-get)))
-    3)))
+                (list (finish-activity 0)))))
 
-(define (image-from-unique-id db table unique-id)
+            (else
+             (vert
+              (image-button
+               (make-id (string-append "chooser-" id))
+               image (layout (car button-size) (cadr button-size) 1 'centre 5)
+               (lambda ()
+                 (set-current! 'choose-result id)
+                 (list (finish-activity 0))))
+              (text-view 0 (ktv-get e "name") 20 (layout 'wrap-content 'wrap-content -1 'centre 0)))
+             ))))
+       search)
+     3))))
+
+(define (image/name-from-unique-id db table unique-id)
   (let ((e (get-entity-by-unique db table unique-id)))
-    (ktv-get e "photo")))
+    (list
+     (ktv-get e "name")
+     (ktv-get e "photo"))))
 
 (define (build-person-selector id key filter request-code)
   (vert
    (mtitle id)
    (image-view (make-id (string-append (symbol->string id) "-image"))
                "face" (layout 240 320 -1 'centre 0))
+   (mtext-small (string->symbol (string-append (symbol->string id) "-text")))
    (button
     (make-id (string-append "change-" (symbol->string id)))
     (mtext-lookup 'change-id)
@@ -591,6 +627,7 @@
    (mtitle id)
    (image-view (make-id (string-append (symbol->string id) "-image"))
                "face" (layout 120 160 -1 'centre 0))
+   (mtext-small (string->symbol (string-append (symbol->string id) "-text")))
    (button
     (make-id (string-append "change-" (symbol->string id)))
     (mtext-lookup 'change-id)
@@ -611,12 +648,18 @@
   (msg "update-person-selector" key)
   (let ((entity-id (entity-get-value key)))
     (msg "entity-id is" entity-id)
-    (let ((image-name (image-from-unique-id db table entity-id))
-          (id (get-id (string-append (symbol->string id) "-image"))))
-      (msg "image-name is" image-name)
-      (if (image-invalid? image-name)
-          (update-widget 'image-view id 'image "face")
-          (update-widget 'image-view id 'external-image (string-append dirname "files/" image-name))))))
+    (let ((image-name (image/name-from-unique-id db table entity-id))
+          (id (get-id (string-append (symbol->string id) "-image")))
+          (text-id (get-id (string-append (symbol->string id) "-text"))))
+      (msg "image-name is" (cadr image-name) (image-invalid? (cadr image-name)))
+      (if (image-invalid? (cadr image-name))
+          (list
+           (update-widget 'image-view id 'image "face")
+           (update-widget 'text-view text-id 'text (car image-name)))
+          (list
+           (update-widget 'text-view text-id 'text (car image-name))
+           (update-widget 'image-view id 'external-image
+                          (string-append dirname "files/" (cadr image-name))))))))
 
 (define (build-social-connection id key type request-code)
   (let ((id-text (string-append (symbol->string id))))
@@ -650,20 +693,21 @@
 
 (define (update-social-connection db table id key type request-code)
   (let ((id-text (string-append (symbol->string id))))
-    (list
+    (append
      (update-person-selector db table id key)
-     (mupdate-spinner-other
-      (string->symbol (string-append id-text "-relationship"))
-      (string-append key "-relationship")
-      social-relationship-list)
-     (mupdate-spinner-other
-      (string->symbol (string-append id-text "-residence"))
-      (string-append key "-residence")
-      social-residence-list)
-     (mupdate-spinner
-      (string->symbol (dbg (string-append id-text "-strength")))
-      (string-append key "-strength")
-      social-strength-list)
+     (list
+      (mupdate-spinner-other
+       (string->symbol (string-append id-text "-relationship"))
+       (string-append key "-relationship")
+       social-relationship-list)
+      (mupdate-spinner-other
+       (string->symbol (string-append id-text "-residence"))
+       (string-append key "-residence")
+       social-residence-list)
+      (mupdate-spinner
+       (string->symbol (dbg (string-append id-text "-strength")))
+       (string-append key "-strength")
+       social-strength-list))
      )))
 
 (define (build-amenity-widgets id shade)
@@ -730,11 +774,7 @@
      (mbutton-scale 'find-individual (lambda () (list (start-activity "individual-chooser" choose-code "")))))
     (build-list-widget
      db "sync" 'villages "village" "village" (lambda () #f)
-     (list
-      (ktv-create "name" "varchar" (mtext-lookup 'default-village-name))
-      (ktv-create "block" "varchar" "")
-      (ktv-create "district" "varchar" "test")
-      (ktv-create "car" "int" 0))))
+     village-ktvlist))
 
    (lambda (activity arg)
      (set-current! 'activity-title "Main screen")
@@ -824,13 +864,7 @@
    (build-activity
     (build-list-widget
      db "sync" 'households "household" "household" (lambda () (get-current 'village #f))
-     (list
-      (ktv-create "name" "varchar" (mtext-lookup 'default-household-name))
-      (ktv-create "num-pots" "int" 0)
-      (ktv-create "house-lat" "real" 0) ;; get from current location?
-      (ktv-create "house-lon" "real" 0)
-      (ktv-create "toilet-lat" "real" 0)
-      (ktv-create "toilet-lon" "real" 0))))
+     household-ktvlist))
    (lambda (activity arg)
      (set-current! 'activity-title "Household List")
      (activity-layout activity))
@@ -1023,19 +1057,20 @@
      (set-current! 'activity-title "Individual family")
       (activity-layout activity))
    (lambda (activity arg)
-     (list
+     (append
       (update-person-selector db "sync" 'spouse "id-spouse")
-      (mupdate-spinner 'head-of-house "head-of-house" '(male female))