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 @@
android:versionName="1.0">
<application android:label="@string/app_name"
android:icon="@drawable/logo"
android:theme="@style/StarwispTheme"
android:hardwareAccelerated="true"
>
......
......@@ -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))
......
......@@ -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")
(mtext "" "Database")