Commit 036b1e9c authored by Dave Griffiths's avatar Dave Griffiths
Browse files

getting the layouts sorted properly, relative layout added

parent 802cccb8
...@@ -5,6 +5,7 @@ ...@@ -5,6 +5,7 @@
android:versionName="1.0"> android:versionName="1.0">
<application android:label="@string/app_name" <application android:label="@string/app_name"
android:icon="@drawable/logo" android:icon="@drawable/logo"
android:theme="@style/StarwispTheme"
android:hardwareAccelerated="true" android:hardwareAccelerated="true"
> >
......
...@@ -16,8 +16,6 @@ ...@@ -16,8 +16,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; debugging and unit tests ;; debugging and unit tests
(alog "hello from lib.scm")
(define (msg . args) (define (msg . args)
(for-each (for-each
(lambda (i) (display i)(display " ")) (lambda (i) (display i)(display " "))
...@@ -413,13 +411,7 @@ ...@@ -413,13 +411,7 @@
;; android ui ;; android ui
(define (layout width height weight gravity margin) (list "layout" width height weight gravity margin)) (define (layout width height weight gravity margin) (list "layout" width height weight gravity margin))
(define (layout-width l) (list-ref l 1)) (define (rlayout width height margin rules) (list "relative-layout" width height margin rules))
(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 (widget-type w) (list-ref w 0)) (define (widget-type w) (list-ref w 0))
(define (widget-id w) (list-ref w 1)) (define (widget-id w) (list-ref w 1))
...@@ -428,6 +420,9 @@ ...@@ -428,6 +420,9 @@
(define (linear-layout id orientation layout colour children) (define (linear-layout id orientation layout colour children)
(list "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 (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) (define (frame-layout id layout children)
(list "frame-layout" id layout children)) (list "frame-layout" id layout children))
(define (frame-layout-children t) (list-ref t 3)) (define (frame-layout-children t) (list-ref t 3))
...@@ -615,10 +610,10 @@ ...@@ -615,10 +610,10 @@
(* (/ (prof-item-accum d) tot) 100) "%")) (* (/ (prof-item-accum d) tot) 100) "%"))
prof-map))) prof-map)))
(define wrap (layout 'wrap-content 'wrap-content 1 'left 0)) (define wrap (layout 'wrap-content 'wrap-content -1 'left 0))
(define fillwrap (layout 'fill-parent '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 wrapfill (layout 'wrap-content 'fill-parent -1 'left 0))
(define fill (layout 'fill-parent '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))) (define (spacer size) (space (layout 'fill-parent size 1 'left 0)))
...@@ -626,17 +621,30 @@ ...@@ -626,17 +621,30 @@
(define (horiz . l) (define (horiz . l)
(linear-layout (linear-layout
0 'horizontal 0 'horizontal
(layout 'fill-parent 'wrap-content 1 'left 0) (layout 'fill-parent 'wrap-content -1 'left 0)
(list 0 0 0 0) (list 0 0 0 0)
l)) l))
(define (vert . l) (define (vert . l)
(linear-layout (linear-layout
0 'vertical 0 'vertical
(layout 'fill-parent 'wrap-content 1 'left 0) (layout 'fill-parent 'wrap-content 1 'left 20)
(list 0 0 0 0) (list 0 0 0 0)
l)) 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) (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)) (list name layout on-create on-start on-resume on-pause on-stop on-destroy on-activity-result))
...@@ -678,6 +686,7 @@ ...@@ -678,6 +686,7 @@
(define (widget-get-children w) (define (widget-get-children w)
(cond (cond
((equal? (widget-type w) "linear-layout") (linear-layout-children w)) ((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) "frame-layout") (frame-layout-children w))
((equal? (widget-type w) "scroll-view") (scroll-view-children w)) ((equal? (widget-type w) "scroll-view") (scroll-view-children w))
((equal? (widget-type w) "draggable") (draggable-children w)) ((equal? (widget-type w) "draggable") (draggable-children w))
......
...@@ -38,297 +38,39 @@ ...@@ -38,297 +38,39 @@
;;(display (db-all db "local" "app-settings"))(newline) ;;(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 ;; user interface abstraction
(define (mbutton id title fn) (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) (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) (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) (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) (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) (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) (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) (define (mtext id text)
(text-view (make-id id) text 30 wrap)) (text-view (make-id id) text 30 wrap))
(define (mtitle id text) (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) (define (medit-text id text type fn)
(vert (vert
...@@ -360,83 +102,6 @@ ...@@ -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) (define (db-mongooses-by-pack)
(db-all-where (db-all-where
db "sync" "mongoose" db "sync" "mongoose"
...@@ -480,57 +145,6 @@ ...@@ -480,57 +145,6 @@
(ktv "pack-id" "varchar" (ktv-get (get-current 'pack '()) "unique_id")) (ktv "pack-id" "varchar" (ktv-get (get-current 'pack '()) "unique_id"))
(ktv "dob" "varchar" (date->string (date-minus-months (date-time) 6))))) (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")