getting the layouts sorted properly, relative layout added

android/AndroidManifest.xml

@@ -5,6 +5,7 @@
       android:versionName="1.0">
     <application android:label="@string/app_name"
                  android:icon="@drawable/logo"
+                 android:theme="@style/StarwispTheme"
                  android:hardwareAccelerated="true"
                  >
 

android/assets/lib.scm

@@ -16,8 +16,6 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; debugging and unit tests
 
-(alog "hello from lib.scm")
-
 (define (msg . args)
   (for-each
    (lambda (i) (display i)(display " "))
@@ -413,13 +411,7 @@
 ;; android ui
 
 (define (layout width height weight gravity margin) (list "layout" width height weight gravity margin))
-(define (layout-width l) (list-ref l 1))
-(define (layout-height l) (list-ref l 2))
-(define (layout-weight l) (list-ref l 3))
-(define (layout-gravity l) (list-ref l 4))
-(define (layout-margin l) (list-ref l 5))
-
-(define centre-layout (layout 'wrap-content 'wrap-content 1 'centre 0))
+(define (rlayout width height margin rules) (list "relative-layout" width height margin rules))
 
 (define (widget-type w) (list-ref w 0))
 (define (widget-id w) (list-ref w 1))
@@ -428,6 +420,9 @@
 (define (linear-layout id orientation layout colour children)
   (list "linear-layout" id orientation layout colour children))
 (define (linear-layout-children t) (list-ref t 5))
+(define (relative-layout id layout colour children)
+  (list "relative-layout" id layout colour children))
+(define (relative-layout-children t) (list-ref t 4))
 (define (frame-layout id layout children)
   (list "frame-layout" id layout children))
 (define (frame-layout-children t) (list-ref t 3))
@@ -615,10 +610,10 @@
              (* (/ (prof-item-accum d) tot) 100) "%"))
      prof-map)))
 
-(define wrap (layout 'wrap-content 'wrap-content 1 'left 0))
-(define fillwrap (layout 'fill-parent 'wrap-content 1 'left 0))
-(define wrapfill (layout 'wrap-content 'fill-parent 1 'left 0))
-(define fill (layout 'fill-parent 'fill-parent 1 'left 0))
+(define wrap (layout 'wrap-content 'wrap-content -1 'left 0))
+(define fillwrap (layout 'fill-parent 'wrap-content -1 'left 0))
+(define wrapfill (layout 'wrap-content 'fill-parent -1 'left 0))
+(define fill (layout 'fill-parent 'fill-parent -1 'left 0))
 
 (define (spacer size) (space (layout 'fill-parent size 1 'left 0)))
 
@@ -626,17 +621,30 @@
 (define (horiz . l)
   (linear-layout
    0 'horizontal
-   (layout 'fill-parent 'wrap-content 1 'left 0)
+   (layout 'fill-parent 'wrap-content -1 'left 0)
    (list 0 0 0 0)
    l))
 
 (define (vert . l)
   (linear-layout
    0 'vertical
-   (layout 'fill-parent 'wrap-content 1 'left 0)
+   (layout 'fill-parent 'wrap-content 1 'left 20)
    (list 0 0 0 0)
    l))
 
+(define (vert-fill . l)
+  (linear-layout
+   0 'vertical
+   (layout 'fill-parent 'fill-parent 1 'left 0)
+   (list 0 0 0 0)
+   l))
+
+(define (relative-rules rules . l)
+  (relative-layout
+   0 (rlayout 'fill-parent 'wrap-content 20 rules)
+   (list 0 255 0 127)
+   l))
+
 (define (activity name layout on-create on-start on-resume on-pause on-stop on-destroy on-activity-result)
   (list name layout on-create on-start on-resume on-pause on-stop on-destroy on-activity-result))
 
@@ -678,6 +686,7 @@
 (define (widget-get-children w)
   (cond
    ((equal? (widget-type w) "linear-layout") (linear-layout-children w))
+   ((equal? (widget-type w) "relative-layout") (relative-layout-children w))
    ((equal? (widget-type w) "frame-layout") (frame-layout-children w))
    ((equal? (widget-type w) "scroll-view") (scroll-view-children w))
    ((equal? (widget-type w) "draggable") (draggable-children w))

android/assets/starwisp.scm

@@ -38,297 +38,39 @@
 
 ;;(display (db-all db "local" "app-settings"))(newline)
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; stuff in memory
-
-(define (store-set store key value)
-  (cond
-   ((null? store) (list (list key value)))
-   ((eq? key (car (car store)))
-    (cons (list key value) (cdr store)))
-   (else
-    (cons (car store) (store-set (cdr store) key value)))))
-
-(define (store-get store key default)
-  (cond
-   ((null? store) default)
-   ((eq? key (car (car store)))
-    (cadr (car store)))
-   (else
-    (store-get (cdr store) key default))))
-
-(define (store-exists? store key)
-  (cond
-   ((null? store) #f)
-   ((eq? key (car (car store)))
-    #t)
-   (else
-    (store-exists? (cdr store) key))))
-
-(define store '())
-
-(define (set-current! key value)
-  (set! store (store-set store key value)))
-
-(define (get-current key default)
-  (store-get store key default))
-
-(define (current-exists? key)
-  (store-exists? store key))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; db abstraction
-
-;; store a ktv, replaces existing with same key
-(define (entity-add-value! key type value)
-  (set-current!
-   'entity-values
-   (ktv-set
-    (get-current 'entity-values '())
-    (ktv key type value))))
-
-(define (entity-set! ktv-list)
-  (set-current! 'entity-values ktv-list))
-
-(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)))
-
-;; 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-reset!)
-  (set-current! 'entity-values '()))
-
-(define (assemble-array entities)
-  (foldl
-   (lambda (i r)
-     (if (equal? r "") (ktv-get i "unique_id")
-         (string-append r "," (ktv-get i "unique_id"))))
-   ""
-   entities))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; syncing code
-
-(define url "http://192.168.2.1:8888/mongoose?")
-
-(define (build-url-from-ktv ktv)
-  (string-append "&" (ktv-key ktv) ":" (ktv-type ktv) "=" (stringify-value-url ktv)))
-
-(define (build-url-from-ktvlist ktvlist)
-  (foldl
-   (lambda (ktv r)
-     (string-append r (build-url-from-ktv ktv)))
-   "" ktvlist))
-
-(define (build-url-from-entity table e)
-  (string-append
-   url
-   "fn=sync"
-   "&table=" table
-   "&entity-type=" (list-ref (car e) 0)
-   "&unique-id=" (list-ref (car e) 1)
-   "&dirty=" (number->string (list-ref (car e) 2))
-   "&version=" (number->string (list-ref (car e) 3))
-   (build-url-from-ktvlist (cadr e))))
-
-;; spit all dirty entities to server
-(define (spit db table entities)
-  (foldl
-   (lambda (e r)
-     (debug! (string-append "Sending a " (car (car e)) " to Raspberry Pi"))
-     (append
-      (list
-       (http-request
-        (string-append "req-" (list-ref (car e) 1))
-        (build-url-from-entity table e)
-        (lambda (v)
-          (cond
-           ((or (equal? (car v) "inserted") (equal? (car v) "match"))
-            (update-entity-clean db table (cadr v))
-            (debug! (string-append "Uploaded " (car (car e)))))
-           ((equal? (car v) "no change")
-            (debug! (string-append "No change for " (car (car e)))))
-           ((equal? (car v) "updated")
-            (update-entity-clean db table (cadr v))
-            (debug! (string-append "Updated changed " (car (car e)))))
-           (else
-            (debug! (string-append
-                     "Problem uploading "
-                     (car (car e)) " : " (car v)))))
-          (list
-           (update-widget 'text-view (get-id "sync-dirty") 'text (build-dirty))))))
-      r))
-   '()
-   entities))
-
-(define (suck-entity-from-server db table unique-id exists)
-  ;; ask for the current version
-  (http-request
-   (string-append unique-id "-update-new")
-   (string-append url "fn=entity&table=" table "&unique-id=" unique-id)
-   (lambda (data)
-     ;; check "sync-insert" in sync.ss raspberry pi-side for the contents of 'entity'
-     (let ((entity (list-ref data 0))
-           (ktvlist (list-ref data 1)))
-       (if (not exists)
-           (insert-entity-wholesale
-            db table
-            (list-ref entity 0) ;; entity-type
-            (list-ref entity 1) ;; unique-id
-            0 ;; dirty
-            (list-ref entity 2) ;; version
-            ktvlist)
-           (update-to-version
-            db table (get-entity-id db table unique-id)
-            (list-ref entity 2) ktvlist))
-       (debug! (string-append (if exists "Got new: " "Updated: ") (ktv-get ktvlist "name")))
-       (list
-        (update-widget 'text-view (get-id "sync-dirty") 'text (build-dirty)))))))
-
-;; repeatedly read version and request updates
-(define (suck-new db table)
-  (debug! "Requesting new entities")
-  (list
-   (http-request
-    "new-entities-req"
-    (string-append url "fn=entity-versions&table=" table)
-    (lambda (data)
-      (let ((r (foldl
-                (lambda (i r)
-                  (let* ((unique-id (car i))
-                         (version (cadr i))
-                         (exists (entity-exists? db table unique-id))
-                         (old
-                          (if exists
-                              (> version (get-entity-version
-                                          db table
-                                          (get-entity-id db table unique-id)))
-                              #f)))
-                    ;; 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 exists) r)
-                        r)))
-                '()
-                data)))
-        (cond
-         ((null? r)
-          (debug! "No new data to download")
-          (set-current! 'download 1)
-          (append
-           (if (eqv? (get-current 'upload 0) 1)
-               (list (play-sound "ping")) '())
-           (list
-            (toast "No new data to download")) r))
-         (else
-          (debug! (string-append
-                   "Requesting "
-                   (number->string (length r)) " entities"))
-          (cons
-           (play-sound "active")
-           r))))))))
-
-(define (build-dirty)
-  (let ((sync (get-dirty-stats db "sync"))
-        (stream (get-dirty-stats db "stream")))
-    (string-append
-     "Pack data: " (number->string (car sync)) "/" (number->string (cadr sync)) " "
-     "Focal data: " (number->string (car stream)) "/" (number->string (cadr stream)))))
-
-(define (upload-dirty db)
-  (let ((r (append
-            (spit db "sync" (dirty-entities db "sync"))
-            (spit db "stream" (dirty-entities db "stream")))))
-    (append (cond
-             ((> (length r) 0)
-              (debug! (string-append "Uploading " (number->string (length r)) " items..."))
-              (list
-               (toast "Uploading data...")
-               (play-sound "active")))
-             (else
-              (debug! "No data changed to upload")
-              (set-current! 'upload 1)
-              (append
-               (if (eqv? (get-current 'download 0) 1)
-                   (list (play-sound "ping")) '())
-               (list
-                (toast "No data changed to upload"))))) r)))
-
-(define (connect-to-net fn)
-  (list
-   (network-connect
-    "network"
-    "mongoose-web"
-    (lambda (state)
-      (debug! (string-append "Raspberry Pi connection state now: " state))
-      (append
-       (if (equal? state "Connected") (fn) '())
-       (list
-        ;;(update-widget 'text-view (get-id "sync-connect") 'text state)
-        ))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; user interface abstraction
 
 (define (mbutton id title fn)
-  (button (make-id id) title 20 fillwrap fn))
+  (button (make-id id) title 30 (layout 'fill-parent 'wrap-content -1 'left 0) fn))
+
+(define (mbutton-scale id title fn)
+  (button (make-id id) title 30 (layout 'fill-parent 'wrap-content 1 'left 0) fn))
 
 (define (mbutton2 id title fn)
-  (button (make-id id) title 30 (layout 150 100 1 'centre 0) fn))
+  (button (make-id id) title 30 (layout 150 100 1 'left 0) fn))
 
 (define (mtoggle-button id title fn)
-  (toggle-button (make-id id) title 30 (layout 'fill-parent 'wrap-content 1 'centre 0) "fancy" fn))
+  (toggle-button (make-id id) title 30 (layout 'fill-parent 'wrap-content 1 'left 0) "fancy" fn))
 
 (define (mtoggle-button-yes id title fn)
-  (toggle-button (make-id id) title 30 (layout 49 43 1 'centre 0) "yes" fn))
+  (toggle-button (make-id id) title 30 (layout 49 43 1 'left 0) "yes" fn))
 
 (define (mtoggle-button-maybe id title fn)
-  (toggle-button (make-id id) title 30 (layout  49 43 1 'centre 0) "maybe" fn))
+  (toggle-button (make-id id) title 30 (layout  49 43 1 'left 0) "maybe" fn))
 
 (define (mtoggle-button-no id title fn)
-  (toggle-button (make-id id) title 30 (layout  49 43 1 'centre 0) "no" fn))
+  (toggle-button (make-id id) title 30 (layout  49 43 1 'left 0) "no" fn))
 
 (define (mtoggle-button2 id title fn)
-  (toggle-button (make-id id) title 30 (layout 150 100 1 'centre 0) "plain" fn))
+  (toggle-button (make-id id) title 30 (layout 150 100 1 'left 0) "plain" fn))
 
 (define (mtext id text)
   (text-view (make-id id) text 30 wrap))
 
 (define (mtitle id text)
-  (text-view (make-id id) text 50 (layout 'fill-parent 'wrap-content 1 'centre 0)))
+  (text-view (make-id id) text 50 (layout 'fill-parent 'wrap-content -1 'left 0)))
 
 (define (medit-text id text type fn)
   (vert
@@ -360,83 +102,6 @@
 
 ;;;;
 
-(define (build-grid-selector name type title)
-  (linear-layout
-   0 'vertical
-   (layout 'fill-parent 'wrap-content 1 'left 0)
-   (list 0 0 0 0)
-   (list
-    (mtext "title" title)
-    (linear-layout
-     0 'horizontal
-     (layout 'fill-parent 'wrap-content 1 'left 2) trans-col
-     (list
-      (image-view (make-id "im") "arrow_left" (layout 200 'fill-parent 1 'left 0))
-      (scroll-view
-       (make-id "scroller")
-       (layout 'wrap-content 'wrap-content 1 'left 20)
-       (list
-        (linear-layout
-         (make-id name) 'horizontal
-         (layout 'wrap-content 'wrap-content 1 'centre 20) trans-col
-         (list
-          (button-grid (make-id name) type 3 30 (layout 100 60 1 'left 40)
-                       (list) (lambda (v) '()))))))
-      (image-view (make-id "im") "arrow_right" (layout 200 'fill-parent 1 'right 0)))))))
-
-;; assumes grid selectors on mongeese only
-(define (fast-get-name item)
-  (list-ref (list-ref item 1) 2))
-
-(define (build-button-items name items unknown)
-  (append
-   (map
-    (lambda (item)
-      (let ((item-name (fast-get-name item)))
-        (list (make-id (string-append name item-name))
-              item
-              item-name)))
-    items)
-   (if unknown
-       (list
-        (list (make-id (string-append name "-unknown"))
-              (list (ktv "name" "varchar" "Unknown")
-                    (ktv "unique_id" "varchar" "Unknown"))
-              "???"))
-       '())))
-
-(define (populate-grid-selector name type items unknown fn)
-  (prof-start "popgrid")
-  (prof-start "popgrid setup")
-  (let ((id->items (build-button-items name items unknown))
-        (selected-set '()))
-    (prof-end "popgrid setup")
-    (let ((r (update-widget
-     'button-grid (get-id name) 'grid-buttons
-     (list
-      type 3 30 (layout 100 60 1 'left 0)
-      (map
-       (lambda (ii)
-         (dbg (list (car ii) (caddr ii))))
-       id->items)
-      (lambda (v state)
-        (cond
-         ((equal? type "toggle")
-          ;; update list of selected items
-          (if state
-              (set! selected-set (set-add v selected-set))
-              (set! selected-set (set-remove v selected-set)))
-          ;; find all items currently selected
-          (fn (map
-               (lambda (v)
-                 (cadr (findv v id->items)))
-               selected-set)))
-         (else
-          ;;(msg (findv v id->items))
-          (fn (cadr (findv v id->items))))))))))
-      (prof-end "popgrid")
-      r)))
-
 (define (db-mongooses-by-pack)
   (db-all-where
    db "sync" "mongoose"
@@ -480,57 +145,6 @@
    (ktv "pack-id" "varchar" (ktv-get (get-current 'pack '()) "unique_id"))
    (ktv "dob" "varchar" (date->string (date-minus-months (date-time) 6)))))
 
-(define (tri-state id text key)
-  (linear-layout
-   (make-id "") 'vertical (layout 'fill-parent 'wrap-content '1 'centre 0) trans-col
-   (list
-    (linear-layout
-     (make-id "") 'horizontal (layout 'wrap-content 'wrap-parent '1 'centre 0) trans-col
-     (list
-      (mtoggle-button-yes
-       (string-append id "-y") ""
-       (lambda (v)
-         (cond
-          (v
-           (entity-add-value! key "varchar" "yes")
-           (list
-            (update-widget 'toggle-button (get-id (string-append id "-n")) 'checked 0)
-            (update-widget 'toggle-button (get-id (string-append id "-m")) 'checked 0)))
-               (else
-                (list
-                 (update-widget 'toggle-button (get-id (string-append id "-y")) 'checked 1))))
-              ))
-      (mtoggle-button-maybe
-       (string-append id "-m")  ""
-       (lambda (v)
-         (cond
-          (v
-           (entity-add-value! key "varchar" "maybe")
-           (list
-            (update-widget 'toggle-button (get-id (string-append id "-y")) 'checked 0)
-            (update-widget 'toggle-button (get-id (string-append id "-n")) 'checked 0)))
-          (else
-           (list
-            (update-widget 'toggle-button (get-id (string-append id "-m")) 'checked 1))))
-         ))
-
-      (mtoggle-button-no
-       (string-append id "-n") ""
-       (lambda (v)
-         (cond
-          (v
-           (entity-add-value! key "varchar" "no")
-           (list
-            (update-widget 'toggle-button (get-id (string-append id "-y")) 'checked 0)
-            (update-widget 'toggle-button (get-id (string-append id "-m")) 'checked 0)))
-          (else
-           (list
-            (update-widget 'toggle-button (get-id (string-append id "-n")) 'checked 1))))
-         ))))
-
-    (text-view 0 text 30 (layout 'wrap-content 'wrap-parent '1 'centre 0)))))
-
-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
 
@@ -595,20 +209,6 @@
      (string-append (number->string (get-current 'timer-seconds 59))))
     )))
 
-(define (next-button id dialog-msg next-frag fn)
-     (mbutton (string-append id "-nextb") "Next"
-              (lambda ()
-                (list
-                 (alert-dialog
-                  (string-append id "-d")
-                  dialog-msg
-                  (lambda (v)
-                    (cond
-                     ((eqv? v 1)
-                      (append
-                       (fn) (list (replace-fragment
-                                   (get-id "gc-top") next-frag))))
-                     (else '()))))))))
 
 (define (force-pause)
   (list
@@ -622,8 +222,8 @@
 
   (fragment
    "pf-timer"
-   (linear-layout
-    (make-id "") 'vertical fillwrap trans-col
+   (relative-layout
+    (make-id "") fillwrap trans-col
     (list
      (mtitle "pf-details" "Pack: xxx Pup: xxx")))
    (lambda (fragment arg)
@@ -655,12 +255,29 @@
 
   (activity
    "main"
-   (vert
-    (mtitle "" "Symbai")
 
-
-    (mtext "" "Database")
-;;    (mbutton "main-sync" "Sync database" (lambda () (list (start-activity "sync" 0 ""))))
+   (vert-fill
+    (relative-rules
+     '(("parent-top"))
+     (horiz
+      (mbutton-scale "cancel" "Cancel" (lambda () (list)))
+      (mbutton-scale "ok" "Ok" (lambda () (list)))))
+
+
+    (vert
+     ;;(image-view (make-id "face") "face" (layout 640 470 1 'left 0))
+     (mtitle "" "Symbai")