Commit 9d2f0e89 authored by Dave Griffiths's avatar Dave Griffiths
Browse files

major refactor started

parent abb6c9a5
tools for behavioural research in the wild
Mongoose 2000 Open Sauces Notebook
============= ====================
A remote tool for behaviour researchers in the field A structured notebook for recipes
This diff is collapsed.
This diff is collapsed.
...@@ -50,6 +50,28 @@ ...@@ -50,6 +50,28 @@
(insert (car lst) fn (insert (car lst) fn
(sort (cdr lst) fn)))) (sort (cdr lst) fn))))
;; (chop (1 2 3 4) 2) -> ((1 2) (3 4))
(define (chop l n)
(define (_ in out c)
(display c)(newline)
(cond
((null? in) out)
((zero? c) (_ (cdr in) (cons (list (car in)) out) (- n 1)))
(else (_ (cdr in) (cons (cons (car in) (car out)) (cdr out)) (- c 1)))))
(reverse (map reverse (_ l '(()) n))))
(define (crop l n)
(cond
((null? l) '())
((zero? n) '())
(else (cons (car l) (crop (cdr l) (- n 1))))))
(define (in-list? n l)
(cond
((null? l) #f)
((equal? n (car l)) #t)
(else (in-list? n (cdr l)))))
(define (find n l) (define (find n l)
(cond (cond
((null? l) #f) ((null? l) #f)
...@@ -62,6 +84,15 @@ ...@@ -62,6 +84,15 @@
((eqv? n (car (car l))) (car l)) ((eqv? n (car (car l))) (car l))
(else (findv n (cdr l))))) (else (findv n (cdr l)))))
;; find the index of an item in a flat list
(define (index-find n l)
(define (_ l i)
(cond
((null? l) #f)
((equal? n (car l)) i)
(else (_ (cdr l) (+ i 1)))))
(_ l 0))
(define (sorted-add l i) (define (sorted-add l i)
(cond (cond
((null? l) (list i)) ((null? l) (list i))
...@@ -162,7 +193,7 @@ ...@@ -162,7 +193,7 @@
(insert elt fn (cdr sorted-lst)))))) (insert elt fn (cdr sorted-lst))))))
(define (choose l) (define (choose l)
(list-ref l (abs (random (- (length l) 1))))) (list-ref l (random (length l))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; time ;; time
...@@ -170,10 +201,10 @@ ...@@ -170,10 +201,10 @@
(define (time->seconds t) (define (time->seconds t)
(+ (car t) (/ (cadr t) 1000000))) (+ (car t) (/ (cadr t) 1000000)))
(define start-time (time->seconds (time))) (define start-time (time->seconds (time-of-day)))
(define (time-now) (define (time-now)
(- (time->seconds (time)) start-time)) (- (time->seconds (time-of-day)) start-time))
;; just for graph so don't have to be accurate!!! ;; just for graph so don't have to be accurate!!!
(define (date->day d) (define (date->day d)
...@@ -247,10 +278,13 @@ ...@@ -247,10 +278,13 @@
(display "random: unrecognized message") (display "random: unrecognized message")
(newline)))))))) (newline))))))))
(define random (define rand
(random-maker 19781116)) ;; another arbitrarily chosen birthday (random-maker 19781116)) ;; another arbitrarily chosen birthday
(define rndf random) (define (random n)
(abs (modulo (rand n) n)))
(define rndf rand)
(define (rndvec) (vector (rndf) (rndf) (rndf))) (define (rndvec) (vector (rndf) (rndf) (rndf)))
...@@ -411,13 +445,7 @@ ...@@ -411,13 +445,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))
...@@ -426,6 +454,9 @@ ...@@ -426,6 +454,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))
...@@ -434,6 +465,10 @@ ...@@ -434,6 +465,10 @@
(define (scroll-view-vert id layout children) (define (scroll-view-vert id layout children)
(list "scroll-view-vert" id layout children)) (list "scroll-view-vert" id layout children))
(define (scroll-view-children t) (list-ref t 3)) (define (scroll-view-children t) (list-ref t 3))
(define (draggable id orientation layout colour children listener)
(list "draggable" id orientation layout colour children listener))
(define (draggable-children t) (list-ref t 5))
(define (draggable-listener t) (list-ref t 6))
(define (view-pager id layout fragment-list) (define (view-pager id layout fragment-list)
(list "view-pager" id layout fragment-list)) (list "view-pager" id layout fragment-list))
(define (space layout) (list "space" "999" layout)) (define (space layout) (list "space" "999" layout))
...@@ -447,6 +482,8 @@ ...@@ -447,6 +482,8 @@
(define (edit-text-listener t) (list-ref t 6)) (define (edit-text-listener t) (list-ref t 6))
(define (button id text text-size layout listener) (list "button" id text text-size layout listener)) (define (button id text text-size layout listener) (list "button" id text text-size layout listener))
(define (button-listener t) (list-ref t 5)) (define (button-listener t) (list-ref t 5))
(define (image-button id image layout listener) (list "image-button" id image layout listener))
(define (image-button-listener t) (list-ref t 4))
(define (toggle-button id text text-size layout style listener) (list "toggle-button" id text text-size layout style listener)) (define (toggle-button id text text-size layout style listener) (list "toggle-button" id text text-size layout style listener))
(define (toggle-button-listener t) (list-ref t 6)) (define (toggle-button-listener t) (list-ref t 6))
(define (seek-bar id max layout listener) (list "seek-bar" id max layout listener)) (define (seek-bar id max layout listener) (list "seek-bar" id max layout listener))
...@@ -472,7 +509,10 @@ ...@@ -472,7 +509,10 @@
(define (network-connect name ssid fn) (list "network-connect" 0 "network-connect" name fn ssid)) (define (network-connect name ssid fn) (list "network-connect" 0 "network-connect" name fn ssid))
(define (http-request name url fn) (list "http-request" 0 "http-request" name fn url)) (define (http-request name url fn) (list "http-request" 0 "http-request" name fn url))
(define (http-download name url filename) (list "http-download" 0 "http-download" name filename url)) (define (http-download name url filename) (list "http-download" 0 "http-download" name filename url))
(define (http-upload name url filename) (list "http-upload" 0 "http-upload" name filename url))
(define (send-mail to subject body attachments) (list "send-mail" 0 "send-mail" to subject body attachments)) (define (send-mail to subject body attachments) (list "send-mail" 0 "send-mail" to subject body attachments))
(define (take-photo filename code) (list "take-photo" 0 "take-photo" filename code))
(define (walk-draggable name id fn) (list "walk-draggable" 0 "walk-draggable" name fn id))
(define (dialog-fragment id layout fragment-name fn) (define (dialog-fragment id layout fragment-name fn)
(list "dialog-fragment" 0 "dialog-fragment" id layout fragment-name fn)) (list "dialog-fragment" 0 "dialog-fragment" id layout fragment-name fn))
...@@ -541,18 +581,27 @@ ...@@ -541,18 +581,27 @@
; r))) ; r)))
(define (get-id name) (define (get-id name)
(id-map-get name)) (let ((r (id-map-get name)))
(cond
((zero? r) (msg "no id found for" name) 0)
(else r))))
(define (make-id name) (define (make-id name)
;;(msg "making id for" name)
(let ((id (id-map-get name))) (let ((id (id-map-get name)))
(cond (cond
((zero? id) ((zero? id)
;;(msg "this is a new id")
; (prof-start "make-id") ; (prof-start "make-id")
(id-map-add name current-id) (id-map-add name current-id)
(set! current-id (+ current-id 1)) (set! current-id (+ current-id 1))
; (prof-end "make-id") ; (prof-end "make-id")
(- current-id 1)) (- current-id 1))
(else id)))) (else
;; seems scheme is shut down while the id store keeps going?
(when (> id current-id) (set! current-id (+ id 1)))
;;(msg "we have seen this one before")
id))))
(define prof-map '()) (define prof-map '())
...@@ -608,10 +657,10 @@ ...@@ -608,10 +657,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)))
...@@ -619,17 +668,44 @@ ...@@ -619,17 +668,44 @@
(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 'centre 0)
(list 0 0 0 0) (list 0 0 0 0)
l)) l))
(define (horiz-colour col . l)
(linear-layout
0 'horizontal
(layout 'fill-parent 'wrap-content -1 'centre 0)
col
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 'centre 20)
(list 0 0 0 0)
l))
(define (vert-colour col . l)
(linear-layout
0 'vertical
(layout 'fill-parent 'wrap-content 1 'centre 20)
col
l))
(define (vert-fill . l)
(linear-layout
0 'vertical
(layout 'fill-parent 'fill-parent 1 'left 0)
(list 0 0 0 0) (list 0 0 0 0)
l)) l))
(define (relative rules colour . l)
(relative-layout
0 (rlayout 'fill-parent 'wrap-content 20 rules)
colour
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))
...@@ -671,8 +747,11 @@ ...@@ -671,8 +747,11 @@
(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) "scroll-view-vert") (scroll-view-children w))
((equal? (widget-type w) "draggable") (draggable-children w))
;; ((equal? (widget-type w) "grid-layout") (grid-layout-children w)) ;; ((equal? (widget-type w) "grid-layout") (grid-layout-children w))
(else '()))) (else '())))
...@@ -680,10 +759,12 @@ ...@@ -680,10 +759,12 @@
(cond (cond
((equal? (widget-type w) "edit-text") (edit-text-listener w)) ((equal? (widget-type w) "edit-text") (edit-text-listener w))
((equal? (widget-type w) "button") (button-listener w)) ((equal? (widget-type w) "button") (button-listener w))
((equal? (widget-type w) "image-button") (image-button-listener w))
((equal? (widget-type w) "toggle-button") (toggle-button-listener w)) ((equal? (widget-type w) "toggle-button") (toggle-button-listener w))
((equal? (widget-type w) "seek-bar") (seek-bar-listener w)) ((equal? (widget-type w) "seek-bar") (seek-bar-listener w))
((equal? (widget-type w) "spinner") (spinner-listener w)) ((equal? (widget-type w) "spinner") (spinner-listener w))
((equal? (widget-type w) "button-grid") (button-grid-listener w)) ((equal? (widget-type w) "button-grid") (button-grid-listener w))
((equal? (widget-type w) "draggable") (draggable-listener w))
(else #f))) (else #f)))
;; walk through activity stripping callbacks ;; walk through activity stripping callbacks
...@@ -694,10 +775,11 @@ ...@@ -694,10 +775,11 @@
(else (else
(let* ((w (car widget-list)) (let* ((w (car widget-list))
(c (widget-get-children w))) (c (widget-get-children w)))
(if (not (null? c)) (when (not (null? c))
(update-callbacks! c) (update-callbacks! c))
(let ((cb (widget-get-callback w))) (let ((cb (widget-get-callback w)))
(when cb (add-callback! (callback (widget-id w) (widget-type w) cb)))))) (when cb
(add-callback! (callback (widget-id w) (widget-type w) cb)))))
(update-callbacks! (cdr widget-list))))) (update-callbacks! (cdr widget-list)))))
;; walk through update stripping callbacks ;; walk through update stripping callbacks
...@@ -709,6 +791,7 @@ ...@@ -709,6 +791,7 @@
((null? w) #f) ((null? w) #f)
;; drill deeper ;; drill deeper
((eq? (update-widget-token w) 'contents) ((eq? (update-widget-token w) 'contents)
(msg "updateing contents from callback")
(update-callbacks! (update-widget-value w))) (update-callbacks! (update-widget-value w)))
((eq? (update-widget-token w) 'grid-buttons) ((eq? (update-widget-token w) 'grid-buttons)
(add-callback! (callback (update-widget-id w) (add-callback! (callback (update-widget-id w)
...@@ -762,6 +845,7 @@ ...@@ -762,6 +845,7 @@
(equal? (list-ref event 0) "http-request") (equal? (list-ref event 0) "http-request")
(equal? (list-ref event 0) "network-connect") (equal? (list-ref event 0) "network-connect")
(equal? (list-ref event 0) "delayed") (equal? (list-ref event 0) "delayed")
(equal? (list-ref event 0) "walk-draggable")
(equal? (list-ref event 0) "gps-start")) (equal? (list-ref event 0) "gps-start"))
(add-new-dialog! event))) (add-new-dialog! event)))
events))) events)))
...@@ -832,6 +916,8 @@ ...@@ -832,6 +916,8 @@
((callback-fn cb) (car args))) ((callback-fn cb) (car args)))
((equal? (callback-type cb) "button") ((equal? (callback-type cb) "button")
((callback-fn cb))) ((callback-fn cb)))
((equal? (callback-type cb) "image-button")
((callback-fn cb)))
((equal? (callback-type cb) "toggle-button") ((equal? (callback-type cb) "toggle-button")
((callback-fn cb) (car args))) ((callback-fn cb) (car args)))
((equal? (callback-type cb) "seek-bar") ((equal? (callback-type cb) "seek-bar")
...@@ -840,9 +926,17 @@ ...@@ -840,9 +926,17 @@
((callback-fn cb) (car args))) ((callback-fn cb) (car args)))
((equal? (callback-type cb) "button-grid") ((equal? (callback-type cb) "button-grid")
((callback-fn cb) (car args) (cadr args))) ((callback-fn cb) (car args) (cadr args)))
((equal? (callback-type cb) "draggable")
((callback-fn cb)))
(else (else
(msg "no callbacks for type" (callback-type cb)))))) (msg "no callbacks for type" (callback-type cb))))))
;;(update-callbacks! events) ;; this was just update-callbacks, commented out,
;; expecting trouble here... (but seems to fix new widgets from
;; widget callbacks so far)
(update-callbacks-from-update! events)
(update-dialogs! events) (update-dialogs! events)
(send (scheme->json events)) (send (scheme->json events))
(prof-end "widget-callback"))))) (prof-end "widget-callback")))))
(alog "lib.scm done")
(define lang #f)
(define scheme #f)
(define racket #f)
(define (planet n) #f)
(define jaymccarthy/sqlite:5:1/sqlite #f)
(define (require . args) #f)
(define (provide . args) #f)
(define (all-defined-out) #f)
(define (make-semaphore n) #f)
(define (semaphore-wait n) #f)
(define (semaphore-post n) #f)
;; tinyscheme
(define db-select db-exec)
;; helper to return first instance from a select
(define (select-first db str . args)
(let ((s (apply db-select (append (list db str) args))))
(if (or (null? s) (eq? s #t))
'()
(vector-ref (cadr s) 0))))
;; get a unique hash for this user (used for all the unique-ids)
(define (get-unique user)
(let ((t (time-of-day)))
(string-append
user "-" (number->string (car t)) ":" (number->string (cadr t)))))
This diff is collapsed.
(define i18n-text
(list
(list 'test-num (list "1" "1" "1" "" ))
(list 'test-text (list "I am test text" "I am test text" "I am test text" "" ))
(list 'one (list "one" "" ))
(list 'two (list "two" "" ))
(list 'three (list "three" "" ))
(list 'village (list "Village" "" ))
(list 'household (list "Household" "" ))
(list 'households (list "Households" "" ))
(list 'individual (list "Individual" "" ))
(list 'individuals (list "Individuals" "" ))
(list 'add-item-to-list (list "0" "" ))
(list 'default-village-name (list "New village" "" ))
(list 'title (list "Symbai" "Symbai" "Symbai" "" ))
(list 'sync (list "Sync" "Sync" "Sync" "" ))
(list 'languages (list "Choose language" "Choose language" "Choose language" "" ))
(list 'english (list "English" "English" "English" "" ))
(list 'khasi (list "Khasi" "Khasi" "Khasi" "" ))
(list 'hindi (list "Hindi" "Hindi" "Hindi" "" ))
(list 'user-id (list "User ID" "User ID" "User ID" "" ))
(list 'save (list "Save" "Save" "Save" "" ))
(list 'back (list "Back" "Back" "Back" "" ))
(list 'off (list "Off" "Off" "Off" "" ))
(list 'villages (list "Villages" "Villages" "Villages" "" ))
(list 'list-empty (list "List empty" "" ))
(list 'delete (list "Delete" "" ))
(list 'delete-are-you-sure (list "Are you sure you want to delete this?" "" ))
(list 'save-are-you-sure (list "Are you sure you want to save changes?" "" ))
(list 'quick-name (list "New person name" "" ))
(list 'quick-add (list "Quick add" "" ))
(list 'find-individual (list "Find individual" "" ))
(list 'filter (list "Filter" "" ))
(list 'off (list "Off" "Off" "Off" "" ))
(list 'name (list "Name" "Kyrteng" ))
(list 'sync-all (list "Sync me!" "" ))
(list 'sync-syncall (list "Sync everything" "" ))
(list 'export-data (list "Exporting data" "" ))
(list 'sync-download (list "Download main DB" "" ))
(list 'sync-export (list "Email main DB" "" ))
(list 'email-local (list "Email local DB" "" ))
(list 'debug (list "Debug" "" ))
(list 'sync-back (list "Back" "" ))
(list 'sync-prof (list "Profile" "" ))
(list 'village-name (list "Village name" "Village name" "Village name" "" ))
(list 'block (list "Block" "Block" "Block" "" ))
(list 'district (list "District" "District" "District" "" ))
(list 'car (list "Accessible by car" "" ))
(list 'household-list (list "Household list" "" ))
(list 'amenities (list "Amenities" "" ))
(list 'school (list "School" "" ))
(list 'present (list "Present" "" ))
(list 'closest-access (list "Closest place of access" "" ))
(list 'house-gps (list "GPS" "" ))
(list 'toilet-gps (list "GPS" "" ))
(list 'school-in-village (list "In Village" ))
(list 'school (list "School" "" ))
(list 'school-closest-access (list "Closest access" "" ))
(list 'school-gps (list "GPS" "" ))
(list 'hospital-in-village (list "In Village" ))
(list 'hospital (list "Hospital/Health care centre" "" ))
(list 'hospital-closest-access (list "Closest access" "" ))
(list 'hospital-gps (list "GPS" "" ))
(list 'Post-office-in-village (list "In Village" ))
(list 'post-office (list "Post Office" "" ))
(list 'post-office-closest-access (list "Closest access" "" ))
(list 'post-office-gps (list "GPS" "" ))
(list 'railway-station-in-village (list "In Village" ))
(list 'railway-station (list "Railway station" "" ))
(list 'railway-station-closest-access (list "Closest access" "" ))
(list 'railway-station-gps (list "GPS" "" ))
(list 'State-bus-service-in-village (list "In Village" ))
(list 'state-bus-service (list "Inter-state bus service" "" ))
(list 'state-bus-service-closest-access (list "Closest access" "" ))
(list 'state-bus-service-gps (list "GPS" "" ))
(list 'District-bus-service-in-village (list "In Village" ))
(list 'district-bus-service (list "Inter-village/district bus service" "" ))
(list 'district-bus-service-closest-access (list "Closest access" "" ))
(list 'district-bus-service-gps (list "GPS" "" ))
(list 'Panchayat-in-village (list "In Village" ))
(list 'panchayat (list "Village Panchayat Office" "" ))
(list 'panchayat-closest-access (list "Closest access" "" ))
(list 'panchayat-gps (list "GPS" "" ))
(list 'NGO-in-village (list "In Village" ))
(list 'NGO (list "Presence of NGO's working with them" "" ))
(list 'NGO-closest-access (list "Closest access" "" ))
(list 'NGO-gps (list "GPS" "" ))
(list 'market-in-village (list "In Village" ))
(list 'market (list "Market" "" ))
(list 'market-closest-access (list "Closest access" "" ))
(list 'market-gps (list "GPS" "" ))
(list 'household-name (list "Household name" "" ))
(list 'default-household-name (list "A household" "" ))
(list 'location (list "House location" "" ))
(list 'elevation (list "Elevation" "" ))
(list 'toilet-location (list "Toilet location" "" ))
(list 'children (list "Children" "" ))
(list 'male (list "Male" "Shynrang" ))
(list 'female (list "Female" "Kynthei" ))
(list 'num-pots (list "Number of pots" "" ))
(list 'adults (list "Adults" "" ))
(list 'add-individual (list "Add individual" "" ))
(list 'default-individual-name (list "A person" "" ))
(list 'default-family-name (list "A family" "" ))
(list 'default-photo-id (list "???" "" ))
(list 'name-display (list "Name" "Kyrteng" ))
(list 'photo-id-display (list "Photo ID" "Nombor dur ID" ))
(list 'family-display (list "Family" "Family/Clan" ))
(list 'details-button (list "Details" "" ))