Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
citizen-science
symbai
Commits
036b1e9c
Commit
036b1e9c
authored
Mar 05, 2014
by
Dave Griffiths
Browse files
getting the layouts sorted properly, relative layout added
parent
802cccb8
Changes
3
Hide whitespace changes
Inline
Side-by-side
Showing
3 changed files
with
80 additions
and
433 deletions
+80
-433
android/AndroidManifest.xml
android/AndroidManifest.xml
+1
-0
android/assets/lib.scm
android/assets/lib.scm
+24
-15
android/assets/starwisp.scm
android/assets/starwisp.scm
+55
-418
No files found.
android/AndroidManifest.xml
View file @
036b1e9c
...
...
@@ -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
View file @
036b1e9c
...
...
@@ -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
2
0
)
(
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
View file @
036b1e9c
...
...
@@ -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"
)