Skip to content

GitLab

Commit 1064e159 authored by Dave Griffiths's avatar Dave Griffiths
Browse files

pup focals recording data, csv output started

parent 13b8484a
Hide whitespace changes
Inline Side-by-side
Showing with 276 additions and 187 deletions
android/assets/eavdb.scm
View file @ 1064e159
......@@ -119,6 +119,12 @@
(define (insert-entity db table entity-type user ktvlist)
(insert-entity-wholesale db table entity-type (get-unique user) 1 0 ktvlist))
;; insert an entire entity
(define (insert-entity/get-unique db table entity-type user ktvlist)
(let ((uid (get-unique user)))
(insert-entity-wholesale db table entity-type uid 1 0 ktvlist)
uid))
;; all the parameters - for syncing purposes
(define (insert-entity-wholesale db table entity-type unique-id dirty version ktvlist)
(let ((id (db-insert
......@@ -227,7 +233,7 @@
((null? ktv-list) (list ktv))
((equal? (ktv-key (car ktv-list)) (ktv-key ktv))
(cons ktv (cdr ktv-list)))
(else (cons ktv (ktv-set (cdr ktv-list) ktv)))))
(else (cons (car ktv-list) (ktv-set (cdr ktv-list) ktv)))))
(define (db-all db table type)
......@@ -400,3 +406,56 @@
db (string-append
"select entity_id from " table "_entity where unique_id = ?")
unique-id))
(define (get-entity-name db table unique-id)
(ktv-get (get-entity db table (get-entity-id db table unique-id)) "name"))
(define (get-entity-names db table id-list)
(foldl
(lambda (id r)
(if (equal? r "")
(get-entity-name db table id)
(string-append r ", " (get-entity-name db table id))))
""
id-list))
(define (csv-titles db table entity-type)
(foldl
(lambda (kt r)
(if (equal? r "") (string-append "\"" (ktv-key kt) "\"")
(string-append r ", \"" (ktv-key kt) "\"")))
""
(get-attribute-ids/types db table entity-type)))
(define (csv db table entity-type)
(foldl
(lambda (res r)
(let ((entity (get-entity db table (vector-ref res 0))))
(string-append
r "\n"
(foldl
(lambda (ktv r)
(cond
((equal? (ktv-key ktv) "unique_id") r)
((null? (ktv-value ktv))
(msg "value not found in csv for " (ktv-key ktv))
r)
;; dereferences lists of ids
((and
(> (string-length (ktv-key ktv)) 8)
(equal? (substring (ktv-key ktv) 0 8) "id-list-"))
(string-append r ", \"" (get-entity-names db "sync" (string-split (ktv-value ktv) '(#\,))) "\""))
;; look for unique ids and dereference them
((and
(> (string-length (ktv-key ktv)) 3)
(equal? (substring (ktv-key ktv) 0 3) "id-"))
(string-append r ", \"" (get-entity-name db "sync" (ktv-value ktv)) "\""))
(else
(string-append r ", \"" (stringify-value ktv) "\""))))
entity-type ;; type
entity))))
(csv-titles db table entity-type)
(cdr (db-select
db (string-append
"select entity_id from "
table "_entity where entity_type = ?") entity-type))))
android/assets/lib.scm
View file @ 1064e159
......@@ -108,6 +108,22 @@
(else (_ (+ m 1) top))))))
(_ 0 (- (length l) 1)))
; utils funcs for using lists as sets
(define (set-remove a l)
(cond
((null? l) '())
(else
(if (eqv? (car l) a)
(set-remove a (cdr l))
(cons (car l) (set-remove a (cdr l)))))))
(define (set-add a l)
(if (not (memv a l))
(cons a l) l))
(define (set-contains a l)
(if (not (memq a l)) #f #t))
(define (build-list fn n)
(define (_ fn n l)
......@@ -145,7 +161,7 @@
(cons (car sorted-lst)
(insert elt fn (cdr sorted-lst))))))
(define (choose l)
(define (choose l)
(list-ref l (abs (random (- (length l) 1)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
......@@ -287,6 +303,66 @@
v
(loop (hsrndvec)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (string-split str . rest)
; maxsplit is a positive number
(define (split-by-whitespace str maxsplit)
(define (skip-ws i yet-to-split-count)
(cond
((>= i (string-length str)) '())
((char-whitespace? (string-ref str i))
(skip-ws (+ 1 i) yet-to-split-count))
(else (scan-beg-word (+ 1 i) i yet-to-split-count))))
(define (scan-beg-word i from yet-to-split-count)
(cond
((zero? yet-to-split-count)
(cons (substring str from (string-length str)) '()))
(else (scan-word i from yet-to-split-count))))
(define (scan-word i from yet-to-split-count)
(cond
((>= i (string-length str))
(cons (substring str from i) '()))
((char-whitespace? (string-ref str i))
(cons (substring str from i)
(skip-ws (+ 1 i) (- yet-to-split-count 1))))
(else (scan-word (+ 1 i) from yet-to-split-count))))
(skip-ws 0 (- maxsplit 1)))
; maxsplit is a positive number
; str is not empty
(define (split-by-charset str delimeters maxsplit)
(define (scan-beg-word from yet-to-split-count)
(cond
((>= from (string-length str)) '(""))
((zero? yet-to-split-count)
(cons (substring str from (string-length str)) '()))
(else (scan-word from from yet-to-split-count))))
(define (scan-word i from yet-to-split-count)
(cond
((>= i (string-length str))
(cons (substring str from i) '()))
((memv (string-ref str i) delimeters)
(cons (substring str from i)
(scan-beg-word (+ 1 i) (- yet-to-split-count 1))))
(else (scan-word (+ 1 i) from yet-to-split-count))))
(scan-beg-word 0 (- maxsplit 1)))
; resolver of overloading...
; if omitted, maxsplit defaults to
; (inc (string-length str))
(if (equal? str "") '()
(if (null? rest)
(split-by-whitespace str (+ 1 (string-length str)))
(let ((charset (car rest))
(maxsplit
(if (pair? (cdr rest)) (cadr rest) (+ 1 (string-length str)))))
(cond
((not (positive? maxsplit)) '())
((null? charset) (split-by-whitespace str maxsplit))
(else (split-by-charset str charset maxsplit))))))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; convert scheme values into equivilent json strings
......@@ -512,7 +588,7 @@
;(define (make-id name)
; (prof-start "make-id")
; (prof-start "make-id sorted find")
; (prof-start "make-id sorted find")
; (let ((sf (sorted-find id-map name)))
; (prof-end "make-id sorted find")
; (let ((r (if (not sf)
......@@ -523,7 +599,7 @@
; (set! current-id (+ current-id 1))
; id)
; (cadr sf))))
; (prof-end "make-id")
; (prof-end "make-id")
; r)))
(define (get-id name)
......@@ -531,7 +607,7 @@
(define (make-id name)
(let ((id (id-map-get name)))
(cond
(cond
((zero? id)
; (prof-start "make-id")
(id-map-add name current-id)
......@@ -550,50 +626,50 @@
(define (prof-item-calls p) (list-ref p 3))
(define (prof-item-restart p)
(list
(list
(prof-item-id p)
(time-now)
(prof-item-accum p)
(prof-item-calls p)))
(define (prof-item-end p)
(list
(list
(prof-item-id p)
0
(+ (prof-item-accum p)
(+ (prof-item-accum p)
(- (time-now) (prof-item-time p)))
(+ (prof-item-calls p) 1)))
(define (prof-start id)
(let ((dd (sorted-find prof-map id)))
(if dd
(set! prof-map
(sorted-add
(set! prof-map
(sorted-add
prof-map (prof-item-restart dd)))
(set! prof-map
(sorted-add
(set! prof-map
(sorted-add
prof-map (new-prof-item id))))))
(define (prof-end id)
(let ((d (sorted-find prof-map id)))
(set! prof-map
(sorted-add
prof-map
(set! prof-map
(sorted-add
prof-map
(prof-item-end d)))))
(define (prof-print)
(let ((tot (foldl
(let ((tot (foldl
(lambda (d r)
(+ (prof-item-accum d) r))
0 prof-map)))
(for-each
(lambda (d)
(msg (prof-item-id d)
(prof-item-calls d)
(msg (prof-item-id d)
(prof-item-calls d)
(prof-item-accum d)
(* (/ (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))
......@@ -673,6 +749,7 @@
(else #f)))
;; walk through activity stripping callbacks
;; version called from on-create
(define (update-callbacks! widget-list)
(cond
((null? widget-list) #f)
......@@ -686,6 +763,7 @@
(update-callbacks! (cdr widget-list)))))
;; walk through update stripping callbacks
;; version called with update-widgets (after on-create version above)
(define (update-callbacks-from-update! widget-list)
(if (null? widget-list) #f
(let ((w (car widget-list)))
......@@ -698,7 +776,7 @@
(add-callback! (callback (update-widget-id w)
"button-grid"
(list-ref (update-widget-value w) 5)))))
(update-callbacks! (cdr widget-list)))))
(update-callbacks-from-update! (cdr widget-list)))))
(define (define-activity-list . args)
(set! activities (activity-list args)))
......@@ -770,11 +848,7 @@
(let ((ret (cond
;; todo update activity...?
((eq? type 'on-create) ((activity-on-create activity) activity (car args)))
((eq? type 'on-start)
(alog "running on create")
(let ((r ((activity-on-start activity) activity (car args))))
(alog "done on create") r))
((eq? type 'on-start) ((activity-on-start activity) activity (car args)))
((eq? type 'on-stop) ((activity-on-stop activity) activity))
((eq? type 'on-resume) ((activity-on-resume activity) activity))
((eq? type 'on-pause) ((activity-on-pause activity) activity))
......@@ -812,7 +886,8 @@
((equal? (callback-type cb) "spinner")
((callback-fn cb) (car args)))
((equal? (callback-type cb) "button-grid")
((callback-fn cb) (car args)))
(msg "button grid cb" args)
((callback-fn cb) (car args) (cadr args)))
(else
(msg "no callbacks for type" (callback-type cb))))))
;;(update-callbacks! events)
......
android/assets/starwisp.scm
View file @ 1064e159
......@@ -53,7 +53,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; persistent database
(define db "/sdcard/test.db")
(define db "/sdcard/mongoose/local-mongoose.db")
(db-open db)
(setup db "local")
(setup db "sync")
......@@ -77,14 +77,6 @@
(else
(cons (car store) (store-set (cdr store) key value)))))
(define (store-clear store key)
(cond
((null? store) '())
((eq? key (car (car store)))
(cdr store))
(else
(cons (car store) (store-clear (cdr store) key)))))
(define (store-get store key default)
(cond
((null? store) default)
......@@ -112,27 +104,41 @@
(define (current-exists? key)
(store-exists? store key))
(define (remove-current key)
(store-clear store key))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; db abstraction
;; store a ktv, replaces existing with same key
(define (add-entity-value! key type value)
(set-current!
"entity-values"
(define (entity-add-value! key type value)
(set-current!
'entity-values
(ktv-set
(ktv key type value)
(get-current "entity-values" '()))))
(get-current 'entity-values '())
(ktv key type value))))
;; build entity from all ktvs, insert to db
(define (record-entity-values db table type)
(let ((values (get-current "entity-values" '())))
(insert-entity
db table type (get-current 'user-id "no id")
values)
(remove-current "entity-values")))
;; build entity from all ktvs, insert to db, return unique_id
(define (entity-record-values db table type)
(let ((values (get-current 'entity-values '())))
(msg 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-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
......@@ -290,104 +296,6 @@
;;;;
(define (build-grid-selector name type title)
(build-grid-selector-hw name type title)
;(build-grid-selector-sw name title)
)
(define (populate-grid-selector name type items fn)
(prof-start "populate-grid-selector")
(let ((r
(populate-grid-selector-hw name type items fn)
; (cond
; ((equal? type "button")
; (populate-grid-selector-sw name items fn))
; ((equal? type "toggle")
; (populate-grid-selector-toggle-sw name items fn))
; ((equal? type "single")
; (populate-grid-selector-single-sw name items fn)))
))
(prof-end "populate-grid-selector")
r))
;;;
(define (build-grid-selector-sw name title)
(vert
(mtext "foo" title)
(horiz
(image-view (make-id "im") "arrow_left" (layout 100 'fill-parent 1 'left 0))
(scroll-view
(make-id "scroller")
(layout 'wrap-content 'wrap-content 1 'left 0)
(list
(linear-layout
(make-id name) 'horizontal
(layout 'wrap-content 'wrap-content 1 'centre 0) trans-col (list))))
(image-view (make-id "im") "arrow_right" (layout 100 'fill-parent 1 'right 0)))))
(define (populate-grid-sw name items buildfn)
(update-widget
'linear-layout (get-id name) 'contents
(map
(lambda (items)
;; todo add space for empty parts
(linear-layout
(make-id "foo") 'vertical wrap trans-col
(map buildfn items)))
(xwise 3 items))))
(define (populate-grid-selector-sw name items fn)
(populate-grid-sw
name items
(lambda (item)
(let ((item-name (ktv-get item "name")))
(button
(make-id (string-append name item-name))
item-name 15 (layout 100 40 1 'left 0)
(lambda ()
(fn item)))))
items))
(define (populate-grid-selector-toggle-sw name items fn)
(populate-grid-sw
name items
(lambda (item)
(let ((item-name (ktv-get item "name")))
(toggle-button
(make-id (string-append name item-name))
item-name 15 (layout 100 40 1 'left 0)
(lambda ()
(fn item)))))
items))
(define (populate-grid-selector-single-sw name items fn)
(populate-grid-sw
name items
(lambda (item)
(let ((item-name (ktv-get item "name")))
(toggle-button
(make-id (string-append name item-name))
item-name 15 (layout 100 40 1 'left 0)
(lambda (v)
(append
;; clear all the others except us
(mclear-toggles
(foldl
(lambda (item r)
(let ((tname (ktv-get item "name")))
(if (equal? tname item-name) r
(cons
(string-append name tname) r))))
'() items))
(fn item))))))))
;;;;
(define (build-grid-selector-hw name type title)
(vert
(mtext "title" title)
(horiz
......@@ -417,8 +325,9 @@
item-name)))
items))
(define (populate-grid-selector-hw name type items fn)
(let ((id->items (build-button-items name items)))
(define (populate-grid-selector name type items fn)
(let ((id->items (build-button-items name items))
(selected-set '()))
(update-widget
'button-grid (get-id name) 'grid-buttons
(list
......@@ -427,19 +336,22 @@
(lambda (ii)
(list (car ii) (caddr ii)))
id->items)
(lambda (v)
(msg "grid-selector cb")
(cond
(lambda (v state)
(cond
((equal? type "toggle")
;; update list of selected items
;; call fn with list
(msg v)
(fn (cadr (findv v id->items)))
)
(else
(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))))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
......@@ -510,9 +422,10 @@
(mtext "title" "Nearest Neighbour Scan")
(build-grid-selector "pf-scan-nearest" "single" "Closest Mongoose")
(build-grid-selector "pf-scan-close" "toggle" "Mongooses within 2m")
(mbutton "pf-scan-done" "Done"
(lambda ()
(record-entity-values db "stream" "pup-focal-nearest")
(mbutton "pf-scan-done" "Done"
(lambda ()
(entity-add-value! "parent" "varchar" (get-current 'pup-focal-id ""))
(entity-record-values db "stream" "pup-focal-nearest")
(list (replace-fragment (get-id "pf-top") "pf-timer"))))))
(lambda (fragment arg)
......@@ -520,18 +433,18 @@
(lambda (fragment arg)
(list
(populate-grid-selector
"pf-scan-close" "toggle"
"pf-scan-nearest" "single"
(db-all-where db "sync" "mongoose"
(list "pack-id" (ktv-get (get-current 'pack '()) "unique_id")))
(lambda (individuals)
(lambda (individual)
(entity-add-value! "id-nearest" "varchar" (ktv-get individual "unique_id"))
(list)))
(populate-grid-selector
"pf-scan-nearest" "single"
"pf-scan-close" "toggle"
(db-all-where db "sync" "mongoose"
(list "pack-id" (ktv-get (get-current 'pack '()) "unique_id")))
(lambda (individual)
;(store-entity-value!
; "nearest" "varchar" (ktv-get individual "unique_id"))
(lambda (individuals)
(entity-add-value! "id-list-close" "varchar" (assemble-array individuals))
(list)))
))
(lambda (fragment) '())
......@@ -549,8 +462,14 @@
(build-grid-selector "pf-pupfeed-who" "single" "Who fed the pup?")
(mtext "text" "Food size")
(horiz
(spinner (make-id "pf-pupfeed-size") (list "Small" "Medium" "Large") fillwrap (lambda (v) '()))
(mbutton "pf-pupfeed-done" "Done" (lambda () (list (replace-fragment (get-id "pf-bot") "events")))))))
(spinner (make-id "pf-pupfeed-size") (list "Small" "Medium" "Large") fillwrap
(lambda (v)
(entity-add-value! "size" "varchar" v) '()))
(mbutton "pf-pupfeed-done" "Done"
(lambda ()
(entity-add-value! "parent" "varchar" (get-current 'pup-focal-id ""))
(entity-record-values db "stream" "pup-focal-pupfeed")
(list (replace-fragment (get-id "pf-bot") "events")))))))
(lambda (fragment arg)
(activity-layout fragment))
......@@ -561,6 +480,7 @@
(db-all-where db "sync" "mongoose"
(list "pack-id" (ktv-get (get-current 'pack '()) "unique_id")))
(lambda (individual)
(entity-add-value! "id_who" "varchar" (ktv-get individual "unique_id"))
(list)))
))
(lambda (fragment) '())
......@@ -576,8 +496,13 @@
(mtitle "title" "Event: Pup found food")
(mtext "text" "Food size")
(horiz
(spinner (make-id "pf-pupfind-size") (list "Small" "Medium" "Large") fillwrap (lambda (v) '()))
(mbutton "pf-pupfind-done" "Done" (lambda