diff --git a/android/AndroidManifest.xml b/android/AndroidManifest.xml index bac90ae9b2eb0e054e2601c6f2deda2007fc9b1c..dc7d4aaccc609edb6516647927f37c5b41a14cda 100644 --- a/android/AndroidManifest.xml +++ b/android/AndroidManifest.xml @@ -1,7 +1,7 @@ - + diff --git a/android/README.md b/android/README.md index 40c8db07d9af1aacd2fcd8873bc00b1696710730..93eb891551679585156b5fbf026d2b75a9cc2366 100644 --- a/android/README.md +++ b/android/README.md @@ -1,4 +1,2 @@ -Open Sauces Notebook -==================== - -A structured notebook for recipes +Symbai android app +================== diff --git a/android/assets/dbsync.scm b/android/assets/dbsync.scm index 61ca2e74487cd0ba309ca0ecc86013ef18b2c800..a661fd004634d86a7ffe86ed967b266f0cd807cb 100644 --- a/android/assets/dbsync.scm +++ b/android/assets/dbsync.scm @@ -17,6 +17,8 @@ (msg "dbsync.scm") +(define unset-int 2147483647) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; stuff in memory @@ -88,22 +90,51 @@ (define (entity-get-value key) (ktv-get (get-current 'entity-values '()) key)) +(define (check-type type value) + (cond + ((equal? type "varchar") + (string? value)) + ((equal? type "file") + (string? value)) + ((equal? type "int") + (number? value)) + ((equal? type "real") + (number? value)))) + ;; version to check the entity has the key (define (entity-set-value! key type value) + (when (not (check-type type value)) + (msg "INCORRECT TYPE FOR" key ":" type ":" value)) + (let ((existing-type (ktv-get-type (get-current 'entity-values '()) key))) - (if (equal? existing-type type) - (set-current! - 'entity-values - (ktv-set - (get-current 'entity-values '()) - (ktv key type value))) - ;; - (begin - (msg "entity-set-value! - adding new " key "of type" type "to entity") - (entity-add-value-create! key type value))) - ;; save straight to local db every time - (entity-update-single-value! (list key type value)) - )) + (cond + ((equal? existing-type type) + ;; save straight to local db every time (checks for modification) + (entity-update-single-value! (list key type value)) + ;; then save to memory + (set-current! + 'entity-values + (ktv-set + (get-current 'entity-values '()) + (ktv key type value)))) + ;; + (else + (msg "entity-set-value! - adding new " key "of type" type "to entity") + (entity-add-value-create! key type value)) + ))) + +;; version to check the entity has the key +(define (entity-set-value-mem! key type value) + (when (not (check-type type value)) + (msg "INCORRECT TYPE FOR" key ":" type ":" value)) + + ;; then save to memory + (set-current! + 'entity-values + (ktv-set + (get-current 'entity-values '()) + (ktv key type value)))) + (define (date-time->string dt) @@ -163,6 +194,8 @@ (table (get-current 'table #f)) (unique-id (ktv-get (get-current 'entity-values '()) "unique_id"))) (cond + ((ktv-eq? (ktv-get-whole (get-current 'entity-values '()) (ktv-key ktv)) ktv) + (msg "eusv: no change for" (ktv-key ktv))) (unique-id (update-entity db table (entity-id-from-unique db table unique-id) (list ktv))) (else @@ -455,7 +488,7 @@ (list (network-connect "network" - "mongoose-web" + "symbai-web" (lambda (state) (debug! (string-append "Raspberry Pi connection state now: " state)) (append @@ -575,11 +608,25 @@ (layout 'fill-parent 'wrap-content 1 'centre 0) fn)))) +(define (medit-text-large id type fn) + (linear-layout + (make-id (string-append (symbol->string id) "-container")) + 'vertical + (layout 'fill-parent 'wrap-content 1 'centre 20) + (list 0 0 0 0) + (list + (text-view 0 (mtext-lookup id) + 30 (layout 'wrap-content 'wrap-content -1 'centre 0)) + (edit-text (symbol->id id) "" 30 type + (layout 'fill-parent 300 -1 'left 0) + fn)))) + + (define (mspinner id types fn) (vert (text-view (symbol->id id) (mtext-lookup id) - 30 (layout 'wrap-content 'wrap-content 1 'centre 10)) + 30 (layout 'wrap-content 'wrap-content 1 'centre 0)) (spinner (make-id (string-append (symbol->string id) "-spinner")) (map mtext-lookup types) (layout 'wrap-content 'wrap-content 1 'centre 0) @@ -650,15 +697,19 @@ (define (image-invalid? image-name) (or (null? image-name) (not image-name) - (equal? image-name "none"))) + (equal? image-name "none") + (equal? image-name ""))) ;; fill out the widget from the current entity in the memory store ;; dispatches based on widget type (define (mupdate widget-type id-symbol key) (cond ((or (eq? widget-type 'edit-text) (eq? widget-type 'text-view)) - (update-widget widget-type (get-symbol-id id-symbol) 'text - (entity-get-value key))) + (let ((v (entity-get-value key))) + (update-widget widget-type (get-symbol-id id-symbol) 'text + ;; hide -1 as it represents unset + (if (and (number? v) (eqv? v -1)) + "" v)))) ((eq? widget-type 'toggle-button) (update-widget widget-type (get-symbol-id id-symbol) 'checked (entity-get-value key))) @@ -779,7 +830,7 @@ ;; a standard builder for list widgets of entities and a ;; make new button, to add defaults to the list -(define (build-list-widget db table title entity-type edit-activity parent-fn ktv-default-fn) +(define (build-list-widget db table title title-ids entity-type edit-activity parent-fn ktv-default-fn) (vert-colour colour-two (horiz @@ -794,7 +845,7 @@ (ktvlist-merge (ktv-default-fn) (list (ktv "parent" "varchar" (parent-fn))))) - (list (update-list-widget db table entity-type edit-activity (parent-fn)))))) + (list (update-list-widget db table title-ids entity-type edit-activity (parent-fn)))))) (linear-layout (make-id (string-append entity-type "-list")) 'vertical @@ -802,13 +853,28 @@ (list 0 0 0 0) (list)))) +(define (make-list-widget-title e title-ids) + (if (eqv? (length title-ids) 1) + (ktv-get e (car title-ids)) + (string-append + (ktv-get e (car title-ids)) "\n" + (foldl + (lambda (id r) + (if (equal? r "") + (ktv-get e id) + (string-append r " " (ktv-get e id)))) + "" (cdr title-ids))))) + ;; pull db data into list of button widgets -(define (update-list-widget db table entity-type edit-activity parent) +(define (update-list-widget db table title-ids entity-type edit-activity parent) (let ((search-results (if parent (db-filter-only db table entity-type (list (list "parent" "varchar" "=" parent)) - (list (list "name" "varchar"))) + (map + (lambda (id) + (list id "varchar")) + title-ids)) (db-all db table entity-type)))) (update-widget 'linear-layout @@ -820,8 +886,8 @@ (lambda (e) (button (make-id (string-append "list-button-" (ktv-get e "unique_id"))) - (or (ktv-get e "name") "Unamed item") - 40 (layout 'fill-parent 'wrap-content 1 'centre 5) + (make-list-widget-title e title-ids) + 30 (layout 'fill-parent 'wrap-content 1 'centre 5) (lambda () (list (start-activity edit-activity 0 (ktv-get e "unique_id")))))) search-results))))) @@ -1029,13 +1095,13 @@ (msg "making village" i) (let ((village (simpsons-village db table village-ktvlist))) (looper! - 3 + 15 (lambda (i) (alog "household") (msg "making household" i) (let ((household (simpsons-household db table village household-ktvlist))) (looper! - (random 10) + (+ 2 (random 5)) (lambda (i) (msg "making individual" i) (simpsons-individual db table household individual-ktvlist)))))))))) diff --git a/android/assets/lib.scm b/android/assets/lib.scm index 1916084d217fe571e6984f50dce9598751265147..49a24af1abbe8d2594e9cfd3913e6acd14d5165b 100644 --- a/android/assets/lib.scm +++ b/android/assets/lib.scm @@ -706,7 +706,7 @@ (define (relative rules colour . l) (relative-layout - 0 (rlayout 'fill-parent 'wrap-content 20 rules) + 0 (rlayout 'fill-parent 'wrap-content (list 20 20 20 20) rules) colour l)) @@ -795,7 +795,8 @@ ((null? w) #f) ;; drill deeper ((eq? (update-widget-token w) 'contents) - (msg "updateing contents from callback") + (update-callbacks! (update-widget-value w))) + ((eq? (update-widget-token w) 'contents-add) (update-callbacks! (update-widget-value w))) ((eq? (update-widget-token w) 'grid-buttons) (add-callback! (callback (update-widget-id w) @@ -862,6 +863,7 @@ (begin (display "no dialog called ")(display name)(newline)) (let ((events (apply (dialog-fn dialog) args))) (update-dialogs! events) + (update-callbacks-from-update! events) (send (scheme->json events)))))) ;; called by java diff --git a/android/assets/starwisp.scm b/android/assets/starwisp.scm index a830f131744565a49ea885bfbd54b61228993331..78b49ebc10b5c3a0020a39446193efef5e4b2665 100644 --- a/android/assets/starwisp.scm +++ b/android/assets/starwisp.scm @@ -19,7 +19,7 @@ ;; colours (msg "starting up....") -(define entity-types (list "village" "household" "individual")) +(define entity-types (list "village" "household" "individual" "child" "crop")) (define trans-col (list 0 0 0 0)) (define colour-one (list 0 0 255 100)) @@ -41,8 +41,6 @@ (list (ktv "user-id" "varchar" "not set") (ktv "language" "int" 0) - (ktv "house-id" "int" 0) - (ktv "photo-id" "int" 0) (ktv "current-village" "varchar" "none"))) (define (get-setting-value name) @@ -62,29 +60,41 @@ ;;(display (db-all db "local" "app-settings"))(newline) -(define tribes-list '(khasi other)) -(define subtribe-list '(khynriam pnar bhoi war other)) -(define education-list '(primary middle high secondary university)) -(define married-list '(currently-married currently-single seperated)) -(define residence-list '(birthplace spouse-village)) -(define gender-list '(male female)) -(define house-type-list '(concrete tin thatched other)) +(define tribes-list '(not-set khasi no-answered other)) +(define subtribe-list '(not-set khynriam pnar bhoi war not-answered other)) +(define education-list '(not-set primary middle high secondary university not-answered)) +(define married-list '(not-set currently-married currently-single seperated not-answered)) +(define residence-list '(not-set birthplace spouse-village not-answered)) +(define gender-list '(not-set male female not-answered)) +(define house-type-list '(not-set concrete tin thatched not-answered other)) +(define yesno-list '(not-set yes no not-answered)) (define social-types-list '(knowledge prestige)) -(define social-relationship-list '(mother father sister brother spouse children co-wife spouse-mother spouse-father spouse-brother-wife spouse-sister-husband friend neighbour other)) -(define social-residence-list '(same other)) -(define social-strength-list '(daily weekly monthly less)) +(define social-relationship-list '(not-set mother father sister brother spouse children co-wife spouse-mother spouse-father spouse-brother-wife spouse-sister-husband friend neighbour not-answered other)) +(define social-residence-list '(not-set same not-answered other)) +(define social-strength-list '(not-set daily weekly monthly less not-answered)) (define village-ktvlist (list (ktv "name" "varchar" (mtext-lookup 'default-village-name)) + (ktv "notes" "varchar" "") (ktv "block" "varchar" "") - (ktv "district" "varchar" "test") + (ktv "district" "varchar" "") + (ktv "school-closest-access" "varchar" "") + (ktv "hospital-closest-access" "varchar" "") + (ktv "post-office-closest-access" "varchar" "") + (ktv "railway-station-closest-access" "varchar" "") + (ktv "state-bus-service-closest-access" "varchar" "") + (ktv "district-bus-service-closest-access" "varchar" "") + (ktv "panchayat-closest-access" "varchar" "") + (ktv "ngo-closest-access" "varchar" "") + (ktv "market-closest-access" "varchar" "") (ktv "car" "int" 0))) (define household-ktvlist (list (ktv "name" "varchar" "") + (ktv "notes" "varchar" "") (ktv "num-pots" "int" 0) (ktv "num-children" "int" 0) (ktv "house-lat" "real" 0) ;; get from current location? @@ -94,119 +104,126 @@ (define individual-ktvlist (list + (ktv "edit-history" "varchar" "") + (ktv "social-edit-history" "varchar" "") (ktv "name" "varchar" "") + (ktv "notes" "varchar" "") (ktv "first-name" "varchar" "") (ktv "family" "varchar" "") (ktv "photo-id" "varchar" "") (ktv "photo" "file" "") - (ktv "tribe" "varchar" "") - (ktv "subtribe" "varchar" "") - (ktv "child" "int" 0) - (ktv "age" "int" 0) - (ktv "gender" "varchar" "") - (ktv "literate" "int" 0) - (ktv "education" "varchar" "") + (ktv "agreement-photo" "file" "") + (ktv "agreement-general" "file" "") + (ktv "tribe" "varchar" "not-set") + (ktv "subtribe" "varchar" "not-set") + (ktv "child" "int" -1) + (ktv "age" "int" -1) + (ktv "gender" "varchar" "not-set") + (ktv "literate" "varchar" "not-set") + (ktv "education" "varchar" "not-set") (ktv "head-of-house" "varchar" "") - (ktv "marital-status" "varchar" "") - (ktv "times-married" "int" 0) + (ktv "marital-status" "varchar" "not-set") + (ktv "times-married" "int" -1) (ktv "id-spouse" "varchar" "") - (ktv "children-living" "int" 0) - (ktv "children-dead" "int" 0) - (ktv "children-together" "int" 0) - (ktv "children-apart" "int" 0) + (ktv "children-living" "int" -1) + (ktv "children-dead" "int" -1) + (ktv "children-together" "int" -1) + (ktv "children-apart" "int" -1) (ktv "residence-after-marriage" "varchar" "") - (ktv "num-siblings" "int" 0) - (ktv "birth-order" "int" 0) - (ktv "length-time" "int" 0) + (ktv "num-siblings" "int" -1) + (ktv "birth-order" "int" -1) + (ktv "length-time" "int" -1) (ktv "place-of-birth" "varchar" "") - (ktv "num-residence-changes" "int" 0) - (ktv "village-visits-month" "int" 0) - (ktv "village-visits-year" "int" 0) - (ktv "occupation-agriculture" "int" 0) - (ktv "occupation-gathering" "int" 0) - (ktv "occupation-labour" "int" 0) - (ktv "occupation-cows" "int" 0) - (ktv "occupation-fishing" "int" 0) + (ktv "num-residence-changes" "int" -1) + (ktv "village-visits-month" "int" -1) + (ktv "village-visits-year" "int" -1) + (ktv "occupation-agriculture" "varchar" "not-set") + (ktv "occupation-gathering" "varchar" "not-set") + (ktv "occupation-labour" "varchar" "not-set") + (ktv "occupation-cows" "varchar" "not-set") + (ktv "occupation-fishing" "varchar" "not-set") (ktv "occupation-other" "varchar" "") - (ktv "contribute" "int" 0) - (ktv "own-land" "int" 0) - (ktv "rent-land" "int" 0) - (ktv "hire-land" "int" 0) - (ktv "house-type" "varchar" "") - (ktv "loan" "int" 0) - (ktv "earning" "int" 0) - (ktv "radio" "int" 0) - (ktv "tv" "int" 0) - (ktv "mobile" "int" 0) - (ktv "visit-market" "int" 0) - (ktv "town-sell" "int" 0) + (ktv "contribute" "varchar" "not-set") + (ktv "own-land" "varchar" "not-set") + (ktv "rent-land" "varchar" "not-set") + (ktv "hire-land" "varchar" "not-set") + (ktv "house-type" "varchar" "not-set") + (ktv "loan" "int" -1) + (ktv "earning" "int" -1) + (ktv "radio" "varchar" "not-set") + (ktv "tv" "varchar" "not-set") + (ktv "mobile" "varchar" "not-set") + (ktv "visit-market" "int" -1) + (ktv "town-sell" "int" -1) (ktv "social-one" "varchar" "") (ktv "social-one-nickname" "varchar" "") - (ktv "social-one-relationship" "varchar" "") - (ktv "social-one-residence" "varchar" "") - (ktv "social-one-strength" "varchar" "") + (ktv "social-one-relationship" "varchar" "not-set") + (ktv "social-one-residence" "varchar" "not-set") + (ktv "social-one-strength" "varchar" "not-set") (ktv "social-two" "varchar" "") (ktv "social-two-nickname" "varchar" "") - (ktv "social-two-relationship" "varchar" "") - (ktv "social-two-residence" "varchar" "") - (ktv "social-two-strength" "varchar" "") + (ktv "social-two-relationship" "varchar" "not-set") + (ktv "social-two-residence" "varchar" "not-set") + (ktv "social-two-strength" "varchar" "not-set") (ktv "social-three" "varchar" "") (ktv "social-three-nickname" "varchar" "") - (ktv "social-three-relationship" "varchar" "") - (ktv "social-three-residence" "varchar" "") - (ktv "social-three-strength" "varchar" "") + (ktv "social-three-relationship" "varchar" "not-set") + (ktv "social-three-residence" "varchar" "not-set") + (ktv "social-three-strength" "varchar" "not-set") (ktv "social-four" "varchar" "") (ktv "social-four-nickname" "varchar" "") - (ktv "social-four-relationship" "varchar" "") - (ktv "social-four-residence" "varchar" "") - (ktv "social-four-strength" "varchar" "") + (ktv "social-four-relationship" "varchar" "not-set") + (ktv "social-four-residence" "varchar" "not-set") + (ktv "social-four-strength" "varchar" "not-set") (ktv "social-five" "varchar" "") (ktv "social-five-nickname" "varchar" "") - (ktv "social-five-relationship" "varchar" "") - (ktv "social-five-residence" "varchar" "") - (ktv "social-five-strength" "varchar" "") + (ktv "social-five-relationship" "varchar" "not-set") + (ktv "social-five-residence" "varchar" "not-set") + (ktv "social-five-strength" "varchar" "not-set") (ktv "friendship-one" "varchar" "") (ktv "friendship-one-nickname" "varchar" "") - (ktv "friendship-one-relationship" "varchar" "") - (ktv "friendship-one-residence" "varchar" "") - (ktv "friendship-one-strength" "varchar" "") + (ktv "friendship-one-relationship" "varchar" "not-set") + (ktv "friendship-one-residence" "varchar" "not-set") + (ktv "friendship-one-strength" "varchar" "not-set") (ktv "friendship-two" "varchar" "") (ktv "friendship-two-nickname" "varchar" "") - (ktv "friendship-two-relationship" "varchar" "") - (ktv "friendship-two-residence" "varchar" "") - (ktv "friendship-two-strength" "varchar" "") + (ktv "friendship-two-relationship" "varchar" "not-set") + (ktv "friendship-two-residence" "varchar" "not-set") + (ktv "friendship-two-strength" "varchar" "not-set") (ktv "friendship-three" "varchar" "") (ktv "friendship-three-nickname" "varchar" "") - (ktv "friendship-three-relationship" "varchar" "") - (ktv "friendship-three-residence" "varchar" "") - (ktv "friendship-three-strength" "varchar" "") + (ktv "friendship-three-relationship" "varchar" "not-set") + (ktv "friendship-three-residence" "varchar" "not-set") + (ktv "friendship-three-strength" "varchar" "not-set") (ktv "friendship-four" "varchar" "") (ktv "friendship-four-nickname" "varchar" "") - (ktv "friendship-four-relationship" "varchar" "") - (ktv "friendship-four-residence" "varchar" "") - (ktv "friendship-four-strength" "varchar" "") + (ktv "friendship-four-relationship" "varchar" "not-set") + (ktv "friendship-four-residence" "varchar" "not-set") + (ktv "friendship-four-strength" "varchar" "not-set") (ktv "friendship-five" "varchar" "") (ktv "friendship-five-nickname" "varchar" "") - (ktv "friendship-five-relationship" "varchar" "") - (ktv "friendship-five-residence" "varchar" "") - (ktv "friendship-five-strength" "varchar" "") + (ktv "friendship-five-relationship" "varchar" "not-set") + (ktv "friendship-five-residence" "varchar" "not-set") + (ktv "friendship-five-strength" "varchar" "not-set") )) (define crop-ktvlist (list (ktv "name" "varchar" (mtext-lookup 'default-crop-name)) + (ktv "notes" "varchar" "") (ktv "unit" "varchar" "unit") - (ktv "used" "real" 0) - (ktv "sold" "real" 0) + (ktv "used" "real" -1) + (ktv "sold" "real" -1) (ktv "seed" "varchar" ""))) (define child-ktvlist (list (ktv "name" "varchar" (mtext-lookup 'default-child-name)) - (ktv "alive" "int" 1) - (ktv "gender" "varchar" "") - (ktv "age" "int" 0) - (ktv "living-at-home" "int" 0))) + (ktv "notes" "varchar" "") + (ktv "alive" "varchar" "varchar" "not-set") + (ktv "gender" "varchar" "not-set") + (ktv "age" "int" -1) + (ktv "living-at-home" "varchar" "not-set"))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -219,21 +236,68 @@ (update-widget 'debug-text-view (get-id "sync-debug") 'text (get-current 'debug-text ""))) + +;; return last element from comma seperated list +(define (history-get-last txt) + (let ((l (string-split txt '(#\:)))) + (if (null? l) "" + (car (reverse l))))) + +(define (contains-social? ktv-list) + (foldl + (lambda (ktv r) + (if (and + (not r) + (> (string-length (ktv-key ktv)) 5) + (or + (equal? (substring (ktv-key ktv) 0 6) "friend") + (equal? (substring (ktv-key ktv) 0 6) "social"))) + #t r)) + #f ktv-list)) + +;; go through each dirty entity and stick the user id +;; on the end of the edit history lists - only for individuals +(define (update-edit-history db table user-id) + ;; get dirty individual entities + (let ((de (db-select + db (string-append + "select entity_id from " + table "_entity where dirty=1 and entity_type='individual';")))) + (when (not (null? de)) + (for-each + (lambda (i) + (let* ((entity-id (vector-ref i 0)) + (dirty-items (dbg (get-entity-plain-for-sync db table entity-id)))) + (when (not (null? dirty-items)) + ;; check if social change + (let ((type (if (contains-social? dirty-items) "social-edit-history" "edit-history"))) + ;; check if last editor is different + (let ((editors (car (get-value db table entity-id (list type "varchar"))))) + (when (or (equal? editors "") (not (equal? (history-get-last editors) user-id))) + ;; append user id + (msg "history - setting" type) + (if (equal? editors "") + (update-value db table entity-id (ktv type "varchar" (dbg user-id))) + (update-value db table entity-id (ktv type "varchar" (dbg (string-append editors ":" user-id))))))))))) + (cdr de))))) + (define (debug-timer-cb) + (alog "debug timer cb") (append (cond ((get-current 'sync-on #f) -; (when (zero? (random 10)) -; (msg "mangling...") -; (mangle-test! db "sync" entity-types)) - (msg "one") + ;(when (zero? (random 10)) + ; (msg "mangling...") + ; (mangle-test! db "sync" entity-types)) (set-current! 'upload 0) (set-current! 'download 0) (connect-to-net (lambda () (msg "connected, going in...") + (alog "got here...") + (update-edit-history db "sync" (get-current 'user-id "no id")) (append - (list (toast "sync-cb")) + (list (toast "Syncing")) (upload-dirty db) ;; important - don't receive until all are sent... (if (have-dirty? db "sync") '() @@ -422,6 +486,15 @@ (define button-size (list (inexact->exact (round (* 192 0.9))) (inexact->exact (round (* 256 0.9))))) +(define (get-next-id db table type parent) + (+ 1 (length (filter-entities-inc-deleted + db table type + (list (list "parent" "varchar" "=" parent)))))) + + +(define (make-photo-button-title e) + (string-append + (ktv-get e "name") "\n" (ktv-get e "first-name") " " (ktv-get e "family"))) (define (build-photo-buttons search) (grid-ify @@ -432,10 +505,10 @@ (image (if (image-invalid? image-name) "face" (string-append "/sdcard/symbai/files/" image-name)))) (cond - ((> (length search) 50) + ((> (length search) 500) (button (make-id (string-append "chooser-" id)) - (ktv-get e "name") 30 (layout (car button-size) (/ (cadr button-size) 3) 1 'centre 5) + (make-photo-button-title e) 20 (layout (car button-size) (/ (cadr button-size) 3) 1 'centre 5) (lambda () (set-current! 'choose-result id) (list (finish-activity 0))))) @@ -443,7 +516,7 @@ ((equal? image "face") (button (make-id (string-append "chooser-" id)) - (ktv-get e "name") 30 (layout (car button-size) (cadr button-size) 1 'centre 5) + (make-photo-button-title e) 20 (layout (car button-size) (cadr button-size) 1 'centre 5) (lambda () (set-current! 'choose-result id) (list (finish-activity 0))))) @@ -456,37 +529,73 @@ (lambda () (set-current! 'choose-result id) (list (finish-activity 0)))) - (text-view 0 (ktv-get e "name") 20 (layout 'wrap-content 'wrap-content -1 'centre 0))) + (text-view 0 (make-photo-button-title e) 20 (layout 'wrap-content 'wrap-content -1 'centre 0))) )))) search) 3)) +;; getting late in the day... +(define filter-index 0) +(define filter-households '()) + +(define (gradual-build) + (if (or (null? filter-households) + (> filter-index (- (length filter-households) 1))) + '() + (let ((household (list-ref filter-households filter-index))) + (set! filter-index (+ filter-index 1)) + (let ((search (db-filter-only db "sync" "individual" + (append (filter-get) + (list (list "parent" "varchar" "=" + (ktv-get household "unique_id")))) + (list + (list "photo" "file") + (list "name" "varchar") + (list "first-name" "varchar") + (list "family" "varchar") + )))) + (list + (delayed "filter-delayed" 100 gradual-build) + (update-widget + 'linear-layout (get-id "choose-pics") 'contents-add + (list + (apply vert + (cons (text-view 0 (ktv-get household "name") 40 fillwrap) + (build-photo-buttons search))))) + ))))) + + (define (update-individual-filter-inner households) - (map - (lambda (household) - (let ((search (db-filter-only db "sync" "individual" - (append (filter-get) - (list (list "parent" "varchar" "=" - (ktv-get household "unique_id")))) - (list - (list "photo" "file") - (list "name" "varchar"))))) - (apply vert - (cons (text-view 0 (ktv-get household "name") 20 fillwrap) - (build-photo-buttons search))) - )) - households)) + (set! filter-households households) + (set! filter-index 0) + (delayed "filter-delayed" 100 gradual-build)) (define (update-individual-filter) - (msg "update if") (let ((households (db-filter-only db "sync" "household" (list (list "parent" "varchar" "=" (get-setting-value "current-village"))) (list (list "name" "varchar"))))) - (msg households) + (msg "UIF" households) + (list + ;; clear contents... + (update-widget 'linear-layout (get-id "choose-pics") 'contents '()) + (update-individual-filter-inner households)))) + + +(define (update-individual-filter2) + (alog "uif-inner") + (let ((search (db-filter-only db "sync" "individual" + (filter-get) + (list + (list "photo" "file") + (list "name" "varchar"))))) + (alog "uif-house-search end") (update-widget 'linear-layout (get-id "choose-pics") 'contents - (update-individual-filter-inner households)))) + (build-photo-buttons search)) + )) + + (define (image/name-from-unique-id db table unique-id) (let ((e (get-entity-by-unique db table unique-id))) @@ -530,7 +639,8 @@ ;; from activity on result with request id: choose-code ;; todo determine *which* selector this came from... (define (person-selector-return request-code key choose-code) - (when (eqv? request-code choose-code) + (when (and (eqv? request-code choose-code) + (get-current 'choose-result #f)) (entity-set-value! key "varchar" (get-current 'choose-result "not set")) (entity-update-values!))) @@ -627,6 +737,7 @@ (define (build-amenity-widgets id shade) (let ((id-text (symbol->string id))) + (horiz-colour (if shade colour-one colour-two) (linear-layout @@ -696,7 +807,11 @@ (activity "main" (vert - (mbutton 'start (lambda () (list (start-activity-goto "main2" 0 ""))))) + (image-view 0 "logo" (layout 'wrap-content 'wrap-content -1 'centre 0)) + (button (make-id "main-start") + "Symbai" + 40 (layout 'wrap-content 'wrap-content -1 'centre 5) + (lambda () (list (start-activity-goto "main2" 0 ""))))) (lambda (activity arg) (activity-layout activity)) (lambda (activity arg) '()) @@ -725,7 +840,7 @@ (mbutton-scale 'find-individual (lambda () (list (start-activity "individual-chooser" choose-code ""))))) (build-list-widget - db "sync" 'households "household" "household" (lambda () (get-setting-value "current-village")) + db "sync" 'households (list "name") "household" "household" (lambda () (get-setting-value "current-village")) (lambda () (let ((name ;; if it's the first household - change the id... @@ -736,24 +851,22 @@ (list (list "name" "varchar"))))) (string-append (ktv-get (get-entity-by-unique db "sync" (get-setting-value "current-village")) "name") + ":" (get-setting-value "user-id") - "gamehousehold") + ":gamehousehold") (string-append (ktv-get (get-entity-by-unique db "sync" (get-setting-value "current-village")) "name") - (get-setting-value "user-id") - (number->string (get/inc-setting "house-id")))))) + ":" + (get-setting-value "user-id") ":" + (number->string (get-next-id db "sync" "household" (get-setting-value "current-village"))))))) ;; autogenerate the name from the current ID (ktvlist-merge household-ktvlist (list (ktv "name" "varchar" name)))))) - (mbutton 'villages (lambda () (list (start-activity "villages" 0 "")))) - - (mbutton 'sync (lambda () (list (start-activity "sync" 0 "")))) - (horiz - (medit-text 'house-id "numeric" (lambda (v) (set-setting! "house-id" "int" (string->number v)) (list))) - (medit-text 'photo-id "numeric" (lambda (v) (set-setting! "photo-id" "int" (string->number v)) (list)))) + (mbutton-scale 'villages (lambda () (list (start-activity "villages" 0 "")))) + (mbutton-scale 'sync (lambda () (list (start-activity "sync" 0 ""))))) ) (lambda (activity arg) @@ -768,8 +881,6 @@ (update-top-bar) (list (update-widget 'edit-text (get-id "user-id") 'text (get-setting-value "user-id")) - (update-widget 'edit-text (get-id "house-id") 'text (get-setting-value "house-id")) - (update-widget 'edit-text (get-id "photo-id") 'text (get-setting-value "photo-id")) (update-widget 'spinner (get-id "languages-spinner") 'selection (get-setting-value "language")) (gps-start "gps" (lambda (loc) @@ -778,7 +889,7 @@ (number->string (car loc)) ", " (number->string (cadr loc))))))) (update-list-widget - db "sync" "household" "household" (get-setting-value "current-village")))))) + db "sync" (list "name") "household" "household" (get-setting-value "current-village")))))) (alog "end main start") r)) (lambda (activity) '()) (lambda (activity) '()) @@ -805,7 +916,7 @@ (cadr (list-ref (get-current 'villages-list '()) v))) '())) (build-list-widget - db "sync" 'villages "village" "village" (lambda () #f) + db "sync" 'villages (list "name") "village" "village" (lambda () #f) (lambda () village-ktvlist))) @@ -823,7 +934,7 @@ (find-index-from-name-array (get-current 'villages-list '()) (get-current 'village #f))) - (update-list-widget db "sync" "village" "village" #f)))) + (update-list-widget db "sync" (list "name") "village" "village" #f)))) (lambda (activity) '()) (lambda (activity) '()) (lambda (activity) '()) @@ -834,7 +945,7 @@ (activity "village" - (build-activity + (build-activity (horiz (medit-text 'village-name "normal" (lambda (v) (entity-set-value! "name" "varchar" v) '())) (medit-text 'block "normal" (lambda (v) (entity-set-value! "block" "varchar" v) '()))) @@ -847,6 +958,8 @@ (list (start-activity "household-list" 0 (get-current 'village #f))))) + (medit-text-large 'village-notes "normal" (lambda (v) (entity-set-value! "notes" "varchar" v) '())) + (mtitle 'amenities) (build-amenity-widgets 'school #t) (build-amenity-widgets 'hospital #f) @@ -871,6 +984,7 @@ (list (mupdate 'edit-text 'village-name "name") (mupdate 'edit-text 'block "block") + (mupdate 'edit-text 'village-notes "notes") (mupdate 'edit-text 'district "district") (mupdate 'toggle-button 'car "car")) (update-amenity-widgets 'school) @@ -894,7 +1008,7 @@ "household-list" (build-activity (build-list-widget - db "sync" 'households "household" "household" (lambda () (get-current 'village #f)) + db "sync" 'households (list "name") "household" "household" (lambda () (get-current 'village #f)) (lambda () ;; autogenerate the name from the current ID (ktvlist-merge @@ -903,7 +1017,7 @@ (string-append (ktv-get (get-entity-by-unique db "sync" (get-setting-value "current-village")) "name") (get-setting-value "user-id") - (number->string (get/inc-setting "house-id"))))))))) + (number->string (get-next-id db "sync" "household" (get-setting-value "current-village")))))))))) (lambda (activity arg) (activity-layout activity)) (lambda (activity arg) @@ -911,7 +1025,7 @@ (append (update-top-bar) (list (update-list-widget - db "sync" "household" "household" arg)))) + db "sync" (list "name") "household" "household" arg)))) (lambda (activity) '()) (lambda (activity) '()) (lambda (activity) '()) @@ -922,8 +1036,8 @@ "household" (build-activity (horiz - (medit-text 'num-pots "numeric" (lambda (v) (entity-set-value! "num-pots" "int" v) '())) - (medit-text 'num-children "numeric" (lambda (v) (entity-set-value! "num-children" "int" v) '()))) + (medit-text 'num-pots "numeric" (lambda (v) (entity-set-value! "num-pots" "int" (string->number v)) '())) + (medit-text 'num-children "numeric" (lambda (v) (entity-set-value! "num-children" "int" (string->number v)) '()))) (horiz (vert (mtext 'location) @@ -938,18 +1052,18 @@ (build-list-widget - db "sync" 'individuals "individual" "individual" + db "sync" 'individuals (list "name" "first-name" "family") "individual" "individual" (lambda () (get-current 'household #f)) (lambda () - (let ((photo-id (get/inc-setting "photo-id")) - (household-name (ktv-get (dbg (get-entity-by-unique db "sync" (dbg (get-current 'household #f)))) "name"))) - (msg household-name) + (let ((photo-id (get-next-id db "sync" "individual" (get-current 'household #f))) + (household-name (ktv-get (get-entity-by-unique db "sync" (get-current 'household #f)) "name"))) (ktvlist-merge individual-ktvlist (list (ktv "name" "varchar" (string-append household-name ":" + (get-current 'user-id "no id") ":" (number->string photo-id))) (ktv "photo-id" "varchar" (number->string photo-id)) @@ -959,6 +1073,7 @@ (modulo photo-id (length social-types-list))))) ))))) + (medit-text-large 'household-notes "normal" (lambda (v) (entity-set-value! "notes" "varchar" v) '())) (delete-button)) (lambda (activity arg) @@ -971,7 +1086,8 @@ (append (update-top-bar) (list - (update-list-widget db "sync" "individual" "individual" arg) + (update-list-widget db "sync" (list "name" "first-name" "family") "individual" "individual" arg) + (mupdate 'edit-text 'household-notes "notes") (mupdate 'edit-text 'num-pots "num-pots") (mupdate 'edit-text 'num-children "num-children")) (mupdate-gps 'house "house") @@ -987,30 +1103,41 @@ "individual" (build-activity (horiz - (image-view (make-id "photo") "face" (layout 240 320 -1 'centre 10)) + (vert + (image-view (make-id "photo") "face" (layout 240 320 -1 'centre 10)) + (mbutton + 'change-photo + (lambda () + (set-current! + 'photo-name (string-append (entity-get-value "unique_id") "-" (get-unique "p") "-face.jpg")) + (list + (take-photo (string-append dirname "files/" (get-current 'photo-name "")) photo-code)) + ))) + (vert (mtext 'name-display) (spacer 20) (mtext 'first-name-display) - (spacer 20) - (mtext 'family-display) - (spacer 20) - (mtext 'photo-id-display) )) - (mbutton 'agreement-button (lambda () (list (start-activity "agreement" 0 "")))) + (mtext 'last-editor) (horiz - (mbutton-scale 'details-button (lambda () (list (start-activity "details" 0 "")))) - (mbutton-scale 'family-button (lambda () (list (start-activity "family" 0 ""))))) + (mbutton-scale 'agreement-button (lambda () (list (start-activity "agreement" 0 "")))) + (mbutton-scale 'details-button (lambda () (list (start-activity "details" 0 ""))))) (horiz - (mbutton-scale 'migration-button (lambda () (list (start-activity "migration" 0 "")))) - (mbutton-scale 'income-button (lambda () (list (start-activity "income" 0 ""))))) + (mbutton-scale 'family-button (lambda () (list (start-activity "family" 0 "")))) + (mbutton-scale 'migration-button (lambda () (list (start-activity "migration" 0 ""))))) (horiz - (mbutton-scale 'geneaology-button (lambda () (list (start-activity "geneaology" 0 "")))) - (mbutton-scale 'friendship-button (lambda () (list (start-activity "friendship" 0 ""))))) + (mbutton-scale 'income-button (lambda () (list (start-activity "income" 0 "")))) + (mbutton-scale 'genealogy-button (lambda () (list (start-activity "genealogy" 0 ""))))) + (spacer 20) + (mtext 'last-social-editor) (horiz - (mbutton-scale 'social-button (lambda () (list (start-activity "social" 0 "")))) - (mbutton-scale 'move-button (lambda () (list (start-activity "move" 0 ""))))) + (mbutton-scale 'friendship-button (lambda () (list (start-activity "friendship" 0 "")))) + (mbutton-scale 'social-button (lambda () (list (start-activity "social" 0 ""))))) (spacer 20) + (medit-text-large 'individual-notes "normal" (lambda (v) (entity-set-value! "notes" "varchar" v) '())) + (spacer 20) + (mbutton-scale 'move-button (lambda () (list (start-activity "move" 0 "")))) (delete-button)) (lambda (activity arg) @@ -1019,35 +1146,63 @@ (set-current! 'activity-title "Individual") (entity-init! db "sync" "individual" (get-entity-by-unique db "sync" arg)) (set-current! 'individual arg) + (msg "individual on create") (append (update-top-bar) (list - (mupdate 'text-view 'name-display "name") - (mupdate 'text-view 'first-name-display "first-name") - (mupdate 'text-view 'family-display "family") - (mupdate 'text-view 'photo-id-display "photo-id") + (update-widget 'button (get-id "details-button") 'set-enabled + (if (equal? (entity-get-value "agreement-general") "") 0 1)) + (update-widget 'button (get-id "family-button") 'set-enabled + (if (equal? (entity-get-value "agreement-general") "") 0 1)) + (update-widget 'button (get-id "migration-button") 'set-enabled + (if (equal? (entity-get-value "agreement-general") "") 0 1)) + (update-widget 'button (get-id "income-button") 'set-enabled + (if (equal? (entity-get-value "agreement-general") "") 0 1)) + (update-widget 'button (get-id "genealogy-button") 'set-enabled + (if (equal? (entity-get-value "agreement-general") "") 0 1)) + (update-widget 'button (get-id "friendship-button") 'set-enabled + (if (equal? (entity-get-value "agreement-general") "") 0 1)) + (update-widget 'button (get-id "social-button") 'set-enabled + (if (equal? (entity-get-value "agreement-general") "") 0 1)) + + (update-widget 'button (get-id "change-photo") 'set-enabled + (if (equal? (entity-get-value "agreement-photo") "") 0 1)) + + (update-widget 'text-view (get-id "last-editor") 'text + (string-append "Last edit by " (history-get-last (entity-get-value "edit-history")))) + (update-widget 'text-view (get-id "last-social-editor") 'text + (string-append "Last edit by " (history-get-last (entity-get-value "social-edit-history")))) + (mupdate 'edit-text 'individual-notes "notes") + (update-widget 'text-view (get-id "name-display") 'text (string-append "ID: " (entity-get-value "name"))) + (update-widget 'text-view (get-id "first-name-display") 'text (string-append "Name: " (entity-get-value "first-name") " " (entity-get-value "family"))) (mupdate 'image-view 'photo "photo")))) (lambda (activity) '()) (lambda (activity) '()) (lambda (activity) '()) (lambda (activity) '()) - (lambda (activity requestcode resultcode) '())) + (lambda (activity requestcode resultcode) + (cond + ((eqv? requestcode photo-code) + ;; todo: means we save when the camera happens + ;; need to do this before init is called again in on-start, + ;; which happens next + (let ((unique-id (entity-get-value "unique_id"))) + (when (eqv? resultcode -1) ;; success! + (entity-set-value! "photo" "file" (get-current 'photo-name "error no photo name!!")) + (entity-update-values!)) + ;; need to reset the individual from the db now (as update reset it) + (entity-init! db "sync" "individual" (get-entity-by-unique db "sync" unique-id))) + (list + (mupdate 'image-view 'photo "photo"))) + (else + '())))) (activity "details" (build-activity (horiz - (vert - (image-view (make-id "photo") "face" (layout 240 320 -1 'centre 10)) - (mbutton - 'change-photo - (lambda () - (set-current! - 'photo-name (string-append (entity-get-value "unique_id") "-" (get-unique "p") "-face.jpg")) - (list - (take-photo (string-append dirname "files/" (get-current 'photo-name "")) photo-code)) - ))) + (image-view (make-id "photo") "face" (layout 240 320 -1 'centre 10)) (vert (medit-text 'details-first-name "normal" (lambda (v) (entity-set-value! "first-name" "varchar" v) '())) @@ -1055,13 +1210,24 @@ (mspinner-other 'tribe tribes-list (lambda (v) (entity-set-value! "tribe" "varchar" (spinner-choice tribes-list v)) '())) (mspinner-other 'sub-tribe subtribe-list (lambda (v) (entity-set-value! "subtribe" "varchar" (spinner-choice subtribe-list v)) '())) (horiz - (medit-text 'age "numeric" (lambda (v) (entity-set-value! "age" "int" v) '())) + (medit-text 'birth-year "numeric" (lambda (v) + (entity-set-value! "birth-year" "int" (string->number v)) + (list (update-widget 'text-view (get-id "age") 'text + (string-append + "= " + (number->string (- date-year (string->number v))) + (mtext-lookup 'years-old)))))) + (mtext 'age) (mspinner 'gender gender-list (lambda (v) (entity-set-value! "gender" "varchar" (spinner-choice gender-list v)) '()))) (horiz - (mtoggle-button-scale 'literate (lambda (v) (entity-set-value! "literate" "int" v) '())) - (mspinner 'education education-list (lambda (v) (entity-set-value! "education" "varchar" v) '()))) + (mspinner 'literate yesno-list (lambda (v) (entity-set-value! "literate" "varchar" (spinner-choice yesno-list v)) '())) - (mbutton 'next (lambda () (list (start-activity "family" 0 "")))) + (mspinner 'education education-list + (lambda (v) + (entity-set-value! "education" "varchar" + (spinner-choice education-list v)) '()))) + + (mbutton 'details-next (lambda () (list (start-activity "family" 0 "")))) (spacer 20) ) (lambda (activity arg) @@ -1076,30 +1242,16 @@ (mupdate 'edit-text 'details-first-name "first-name") (mupdate 'edit-text 'details-family "family") (mupdate 'image-view 'photo "photo") - (mupdate 'edit-text 'age "age") + (mupdate 'edit-text 'birth-year "birth-year") (mupdate-spinner 'gender "gender" gender-list) - (mupdate 'toggle-button 'literate "literate") + (mupdate-spinner 'literate "literate" yesno-list) (mupdate-spinner 'education "education" education-list) ))) (lambda (activity) '()) (lambda (activity) '()) (lambda (activity) '()) (lambda (activity) '()) - (lambda (activity requestcode resultcode) - (cond - ((eqv? requestcode photo-code) - ;; todo: means we save when the camera happens - ;; need to do this before init is called again in on-start, - ;; which happens next - (let ((unique-id (entity-get-value "unique_id"))) - (entity-set-value! "photo" "file" (get-current 'photo-name "error no photo name!!")) - (entity-update-values!) - ;; need to reset the individual from the db now (as update reset it) - (entity-init! db "sync" "individual" (get-entity-by-unique db "sync" unique-id))) - (list - (mupdate 'image-view 'photo "photo"))) - (else - '())))) + (lambda (activity requestcode resultcode) '())) (activity "family" @@ -1110,7 +1262,7 @@ (mspinner 'marital-status married-list (lambda (v) (entity-set-value! "marital-status" "varchar" (spinner-choice married-list v)) '())) (medit-text 'times-married "numeric" (lambda (v) - (entity-set-value! "times-married" "int" v) + (entity-set-value! "times-married" "int" (string->number v)) (list (update-widget 'linear-layout (get-id "residence-after-marriage-container") (if (equal? v "0") 'hide 'show) 0))))) @@ -1129,9 +1281,9 @@ (mspinner-other 'residence-after-marriage residence-list (lambda (v) (entity-set-value! "residence-after-marriage" "varchar" (spinner-choice residence-list v)) '())) - (medit-text 'num-siblings "numeric" (lambda (v) (entity-set-value! "num-siblings" "int" v) '())) - (medit-text 'birth-order "numeric" (lambda (v) (entity-set-value! "birth-order" "int" v) '())) - (mbutton 'next (lambda () (list (start-activity "migration" 0 "")))) + (medit-text 'num-siblings "numeric" (lambda (v) (entity-set-value! "num-siblings" "int" (string->number v)) '())) + (medit-text 'birth-order "numeric" (lambda (v) (entity-set-value! "birth-order" "int" (string->number v)) '())) + (mbutton 'family-next (lambda () (list (start-activity "migration" 0 "")))) (spacer 20) ) (lambda (activity arg) @@ -1205,12 +1357,12 @@ (activity "migration" (build-activity - (medit-text 'length-time "numeric" (lambda (v) (entity-set-value! "length-time" "int" v) '())) + (medit-text 'length-time "numeric" (lambda (v) (entity-set-value! "length-time" "int" (string->number v)) '())) (medit-text 'place-of-birth "normal" (lambda (v) (entity-set-value! "place-of-birth" "varchar" v) '())) - (medit-text 'num-residence-changes "numeric" (lambda (v) (entity-set-value! "num-residence-changes" "int" v) '())) - (medit-text 'village-visits-month "numeric" (lambda (v) (entity-set-value! "village-visits-month" "int" v) '())) - (medit-text 'village-visits-year "numeric" (lambda (v) (entity-set-value! "village-visits-year" "int" v) '())) - (mbutton 'next (lambda () (list (start-activity "income" 0 "")))) + (medit-text 'num-residence-changes "numeric" (lambda (v) (entity-set-value! "num-residence-changes" "int" (string->number v)) '())) + (medit-text 'village-visits-month "numeric" (lambda (v) (entity-set-value! "village-visits-month" "int" (string->number v)) '())) + (medit-text 'village-visits-year "numeric" (lambda (v) (entity-set-value! "village-visits-year" "int" (string->number v)) '())) + (mbutton 'migration-next (lambda () (list (start-activity "income" 0 "")))) (spacer 20) ) (lambda (activity arg) @@ -1237,38 +1389,38 @@ (vert (mtitle 'occupation) (horiz - (mtoggle-button-scale 'occupation-agriculture (lambda (v) (entity-set-value! "occupation-agriculture" "int" v) '())) - (mtoggle-button-scale 'occupation-gathering (lambda (v) (entity-set-value! "occupation-gathering" "int" v) '())) - (mtoggle-button-scale 'occupation-labour (lambda (v) (entity-set-value! "occupation-labour" "int" v) '()))) + (mspinner 'occupation-agriculture yesno-list (lambda (v) (entity-set-value! "occupation-agriculture" "varchar" (spinner-choice yesno-list v)) '())) + (mspinner 'occupation-gathering yesno-list (lambda (v) (entity-set-value! "occupation-gathering" "varchar" (spinner-choice yesno-list v)) '())) + (mspinner 'occupation-labour yesno-list (lambda (v) (entity-set-value! "occupation-labour" "varchar" (spinner-choice yesno-list v)) '()))) (horiz - (mtoggle-button-scale 'occupation-cows (lambda (v) (entity-set-value! "occupation-cows" "int" v) '())) - (mtoggle-button-scale 'occupation-fishing (lambda (v) (entity-set-value! "occupation-fishing" "int" v) '())) + (mspinner 'occupation-cows yesno-list (lambda (v) (entity-set-value! "occupation-cows" "varchar" (spinner-choice yesno-list v)) '())) + (mspinner 'occupation-fishing yesno-list (lambda (v) (entity-set-value! "occupation-fishing" "varchar" (spinner-choice yesno-list v)) '())) (medit-text 'occupation-other "normal" (lambda (v) (entity-set-value! "occupation-other" "varchar" v) '())))) (horiz - (mtoggle-button-scale 'contribute (lambda (v) (entity-set-value! "contribute" "int" v) '())) - (mtoggle-button-scale 'own-land (lambda (v) (entity-set-value! "own-land" "int" v) '()))) + (mspinner 'contribute yesno-list (lambda (v) (entity-set-value! "contribute" "varchar" (spinner-choice yesno-list v)) '())) + (mspinner 'own-land yesno-list (lambda (v) (entity-set-value! "own-land" "varchar" (spinner-choice yesno-list v)) '()))) (horiz - (mtoggle-button-scale 'rent-land (lambda (v) (entity-set-value! "rent-land" "int" v) '())) - (mtoggle-button-scale 'hire-land (lambda (v) (entity-set-value! "hire-land" "int" v) '()))) + (mspinner 'rent-land yesno-list (lambda (v) (entity-set-value! "rend-land" "varchar" (spinner-choice yesno-list v)) '())) + (mspinner 'hire-land yesno-list (lambda (v) (entity-set-value! "hire-land" "varchar" (spinner-choice yesno-list v)) '()))) (mtext 'crops-detail) (build-list-widget - db "sync" 'crops "crop" "crop" (lambda () (get-current 'individual #f)) + db "sync" 'crops (list "name") "crop" "crop" (lambda () (get-current 'individual #f)) (lambda () crop-ktvlist)) (mspinner-other 'house-type house-type-list (lambda (v) (entity-set-value! "house-type" "varchar" (spinner-choice house-type-list v)) '())) (horiz - (medit-text 'loan "numeric" (lambda (v) (entity-set-value! "loan" "int" v) '())) - (medit-text 'earning "numeric" (lambda (v) (entity-set-value! "earning" "int" v) '()))) + (medit-text 'loan "numeric" (lambda (v) (entity-set-value! "loan" "int" (string->number v)) '())) + (medit-text 'earning "numeric" (lambda (v) (entity-set-value! "earning" "int" (string->number v)) '()))) (mtext 'in-the-home) (horiz - (mtoggle-button-scale 'radio (lambda (v) (entity-set-value! "radio" "int" v) '())) - (mtoggle-button-scale 'tv (lambda (v) (entity-set-value! "tv" "int" v) '())) - (mtoggle-button-scale 'mobile (lambda (v) (entity-set-value! "mobile" "int" v) '()))) + (mspinner 'radio yesno-list (lambda (v) (entity-set-value! "radio" "varchar" (spinner-choice yesno-list v)) '())) + (mspinner 'tv yesno-list (lambda (v) (entity-set-value! "tv" "varchar" (spinner-choice yesno-list v)) '())) + (mspinner 'mobile yesno-list (lambda (v) (entity-set-value! "mobile" "varchar" (spinner-choice yesno-list v)) '()))) (horiz - (medit-text 'visit-market "numeric" (lambda (v) (entity-set-value! "visit-market" "int" v) '())) - (medit-text 'town-sell "numeric" (lambda (v) (entity-set-value! "town-sell" "int" v) '()))) - (mbutton 'next (lambda () (list (start-activity "geneaology" 0 "")))) + (medit-text 'visit-market "numeric" (lambda (v) (entity-set-value! "visit-market" "int" (string->number v)) '())) + (medit-text 'town-sell "numeric" (lambda (v) (entity-set-value! "town-sell" "int" (string->number v)) '()))) + (mbutton 'income-next (lambda () (list (start-activity "genealogy" 0 "")))) (spacer 20) ) (lambda (activity arg) @@ -1281,22 +1433,22 @@ (update-top-bar) (mupdate-spinner-other 'house-type "house-type" house-type-list) (list - (update-list-widget db "sync" "crop" "crop" (get-current 'individual #f)) - (mupdate 'toggle-button 'occupation-agriculture "occupation-agriculture") - (mupdate 'toggle-button 'occupation-gathering "occupation-gathering") - (mupdate 'toggle-button 'occupation-labour "occupation-labour") - (mupdate 'toggle-button 'occupation-cows "occupation-cows") - (mupdate 'toggle-button 'occupation-fishing "occupation-fishing") + (update-list-widget db "sync" (list "name") "crop" "crop" (get-current 'individual #f)) + (mupdate-spinner 'occupation-agriculture "occupation-agriculture" yesno-list) + (mupdate-spinner 'occupation-gathering "occupation-gathering" yesno-list) + (mupdate-spinner 'occupation-labour "occupation-labour" yesno-list) + (mupdate-spinner 'occupation-cows "occupation-cows" yesno-list) + (mupdate-spinner 'occupation-fishing "occupation-fishing" yesno-list) (mupdate 'edit-text 'occupation-other "occupation-other") - (mupdate 'toggle-button 'contribute "contribute") - (mupdate 'toggle-button 'own-land "own-land") - (mupdate 'toggle-button 'rent-land "rent-land") - (mupdate 'toggle-button 'hire-land "hire-land") - (mupdate 'edit-text 'loan "loan") + (mupdate-spinner 'contribute "contribute" yesno-list) + (mupdate-spinner 'own-land "own-land" yesno-list) + (mupdate-spinner 'rent-land "rent-land" yesno-list) + (mupdate-spinner 'hire-land "hire-land" yesno-list) + (mupdate 'edit-text 'loan "loan" ) (mupdate 'edit-text 'earning "earning") - (mupdate 'toggle-button 'radio "radio") - (mupdate 'toggle-button 'tv "tv") - (mupdate 'toggle-button 'mobile "mobile") + (mupdate-spinner 'radio "radio" yesno-list) + (mupdate-spinner 'tv "tv" yesno-list) + (mupdate-spinner 'mobile "mobile" yesno-list) (mupdate 'edit-text 'visit-market "visit-market") (mupdate 'edit-text 'town-sell "town-sell")))) (lambda (activity) '()) @@ -1314,6 +1466,7 @@ (medit-text 'crop-used "numeric" (lambda (v) (entity-set-value! "used" "real" (string->number v)) '())) (medit-text 'crop-sold "numeric" (lambda (v) (entity-set-value! "sold" "real" (string->number v)) '())) (medit-text 'crop-seed "numeric" (lambda (v) (entity-set-value! "seed" "varchar" v) '())) + (medit-text-large 'crop-notes "normal" (lambda (v) (entity-set-value! "notes" "varchar" v) '())) (delete-button))) (lambda (activity arg) (activity-layout activity)) @@ -1329,6 +1482,7 @@ (mupdate 'edit-text 'crop-used "used") (mupdate 'edit-text 'crop-sold "sold") (mupdate 'edit-text 'crop-seed "seed") + (mupdate 'edit-text 'crop-notes "notes") ))) (lambda (activity) '()) @@ -1346,8 +1500,9 @@ (mspinner 'child-gender gender-list (lambda (v) (entity-set-value! "gender" "varchar" (spinner-choice gender-list v)) '())) (medit-text 'child-age "numeric" (lambda (v) (entity-set-value! "age" "int" (string->number v)) '()))) (horiz - (mtoggle-button-scale 'child-alive (lambda (v) (entity-set-value! "alive" "int" v) '())) - (mtoggle-button-scale 'child-home (lambda (v) (entity-set-value! "living-at-home" "int" v) '()))) + (mspinner-other 'child-alive yesno-list (lambda (v) (entity-set-value! "alive" "varchar" (spinner-choice yesno-list v)) '())) + (mspinner-other 'child-home yesno-list (lambda (v) (entity-set-value! "living-at-home" "varchar" (spinner-choice yesno-list v)) '()))) + (medit-text-large 'child-notes "normal" (lambda (v) (entity-set-value! "notes" "varchar" v) '())) (delete-button))) (lambda (activity arg) (activity-layout activity)) @@ -1361,8 +1516,9 @@ (mupdate 'edit-text 'child-name "name") (mupdate-spinner 'child-gender "gender" gender-list) (mupdate 'edit-text 'child-age "age") - (mupdate 'toggle-button 'child-alive "alive") - (mupdate 'toggle-button 'child-home "living-at-home") + (mupdate 'edit-text 'child-notes "notes") + (mupdate-spinner 'child-alive "alive" yesno-list) + (mupdate-spnner 'child-home "living-at-home" yesno-list) ))) (lambda (activity) '()) @@ -1373,25 +1529,25 @@ (activity - "geneaology" + "genealogy" (build-activity (horiz (build-person-selector 'mother "id-mother" (list) mother-request-code) (build-person-selector 'father "id-father" (list) father-request-code)) (build-list-widget - db "sync" 'children "child" "child" (lambda () (get-current 'individual #f)) + db "sync" 'children (list "name") "child" "child" (lambda () (get-current 'individual #f)) (lambda () child-ktvlist)) - (mbutton 'next (lambda () (list (start-activity "friendship" 0 "")))) + (mbutton 'gene-next (lambda () (list (start-activity "friendship" 0 "")))) (spacer 20)) (lambda (activity arg) (activity-layout activity)) (lambda (activity arg) ;; reset after child entity - (set-current! 'activity-title "Geneaology") + (set-current! 'activity-title "Genealogy") (entity-init! db "sync" "individual" (get-entity-by-unique db "sync" (get-current 'individual #f))) (append (update-top-bar) - (list (update-list-widget db "sync" "child" "child" (get-current 'individual #f))) + (list (update-list-widget db "sync" (list "name") "child" "child" (get-current 'individual #f))) (update-person-selector db "sync" 'mother "id-mother") (update-person-selector db "sync" 'father "id-father"))) (lambda (activity) '()) @@ -1422,7 +1578,7 @@ (build-social-connection 'social-three "social-three" "friend" social-request-code-three #t) (build-social-connection 'social-four "social-four" "friend" social-request-code-four #f) (build-social-connection 'social-five "social-five" "friend" social-request-code-five #t) - (mbutton 'next (lambda () (list (start-activity-goto "individual" 0 (get-current 'individual #f))))) + (mbutton 'social-next (lambda () (list (start-activity-goto "individual" 0 (get-current 'individual #f))))) (spacer 20) ) (lambda (activity arg) @@ -1461,7 +1617,7 @@ (build-social-connection 'social-three "friendship-three" "friend" social-request-code-three #t) (build-social-connection 'social-four "friendship-four" "friend" social-request-code-four #f) (build-social-connection 'social-five "friendship-five" "friend" social-request-code-five #t) - (mbutton 'next (lambda () (list (start-activity "social" 0 "")))) + (mbutton 'friendship-next (lambda () (list (start-activity "social" 0 "")))) (spacer 20) ) (lambda (activity arg) @@ -1491,23 +1647,52 @@ (activity "agreement" (build-activity + (mtext 'general-agreement-text) (horiz - (mtoggle-button-scale 'agree-record (lambda (v) (list - (if (eqv? v 1) (soundfile-start-recording "/sdcard/symbai/test.3gp") - (soundfile-stop-recording))))) + (cond + ((eqv? v 1) + (let ((filename (string-append + "sdcard/symbai/files/" + (entity-get-value "unique_id") "-" (get-unique "general") "-record.3gp"))) + (entity-set-value! "agreement-general" "file" filename) + (soundfile-start-recording filename))) + (else (soundfile-stop-recording)))))) (mtoggle-button-scale 'agree-playback (lambda (v) (list - (if (eqv? v 1) (soundfile-start-playback "/sdcard/symbai/test.3gp") + (if (eqv? v 1) + (soundfile-start-playback (entity-get-value "agreement-general")) + (soundfile-stop-playback))))) + ) + (spacer 100) + (mtext 'photo-agreement-text) + (horiz + (mtoggle-button-scale + 'photo-agree-record + (lambda (v) + (list + (cond + ((eqv? v 1) + (let ((filename (string-append + "sdcard/symbai/files/" + (entity-get-value "unique_id") "-" (get-unique "photo") "-record.3gp"))) + (entity-set-value! "agreement-photo" "file" filename) + (msg "recording" filename) + (soundfile-start-recording filename))) + (else (soundfile-stop-recording)))))) + (mtoggle-button-scale + 'photo-agree-playback + (lambda (v) + (list + (if (eqv? v 1) + (soundfile-start-playback (entity-get-value "agreement-photo")) (soundfile-stop-playback))))) ) - (mbutton 'next (lambda () (list (start-activity "details" 0 "")))) - (spacer 20) ) (lambda (activity arg) (set-current! 'activity-title "Agreement") @@ -1524,6 +1709,13 @@ "individual-chooser" (build-activity (vert + + (linear-layout + (make-id "choose-pics") 'vertical + (layout 'fill-parent 'wrap-content 0.75 'centre 0) + (list 0 0 0 0) + (list)) + (mtitle 'filter) (horiz (mspinner 'gender '(off female male) @@ -1532,7 +1724,8 @@ (filter-remove! "gender") (filter-add! (make-filter "gender" "varchar" "=" (spinner-choice '(off female male) v)))) - (list (update-individual-filter)) + (if (get-current 'filter-switch #f) + (update-individual-filter) '()) )) (medit-text 'name "normal" @@ -1540,15 +1733,13 @@ (if (equal? v "") (filter-remove! "name") (filter-add! (make-filter "name" "varchar" "like" (string-append v "%")))) - (list (update-individual-filter)) - ))) - - (linear-layout - (make-id "choose-pics") 'vertical - (layout 'fill-parent 'wrap-content 0.75 'centre 0) - (list 0 0 0 0) - (list)) - + (if (get-current 'filter-switch #f) + (update-individual-filter) '())) + ) + (mtoggle-button-scale 'filter-switch + (lambda (v) + (set-current! 'filter-switch (not (zero? v))) + (if (not (zero? v)) (update-individual-filter) '())))) (horiz (medit-text 'quick-name "normal" @@ -1581,7 +1772,7 @@ (set-current! 'choose-result #f) (activity-layout activity)) (lambda (activity arg) - (list (update-individual-filter (list)))) + (update-individual-filter (list))) (lambda (activity) '()) (lambda (activity) '()) (lambda (activity) '()) @@ -1615,6 +1806,15 @@ "getting-db" "http://192.168.2.1:8889/symbai.db" (string-append "/sdcard/symbai/symbai.db")) + ;; save paranoid backup + (http-download + "getting-db" + "http://192.168.2.1:8889/symbai.db" + (string-append "/sdcard/symbai/backup/symbai-" (date-time->string (date-time)) ".db")) + (http-download + "getting-log" + "http://192.168.2.1:8889/log.txt" + (string-append "/sdcard/symbai/server-log.txt")) ) entity-types) (list)))) @@ -1625,8 +1825,10 @@ (send-mail "" "From Symbai" "Please find attached your data" - (cons - "/sdcard/symbai/symbai.db" + (append + (list + "/sdcard/symbai/symbai.db" + "/sdcard/symbai/server-log.txt") (map (lambda (e) (string-append "/sdcard/symbai/" e ".csv")) diff --git a/android/assets/translations.csv b/android/assets/translations.csv index fd6af2c3e98bade8f2003f6f737be567ea0dcd75..b067ab1bf3c346017d7d75dfe46711551b3bc991 100644 --- a/android/assets/translations.csv +++ b/android/assets/translations.csv @@ -1,223 +1,266 @@ -test-num,1,1,1, -test-text, I am test text, I am test text, I am test text, -one, one, ,, -two, two, ,, -three, three, ,, -village, Village, ,, -household, Household, ,, -households, Households, ,, -individual, Individual, ,, -individuals, Individuals, ,, -add-item-to-list,0, ,, -default-village-name, New village, ,, -title, Symbai, Symbai, Symbai, -sync, Sync, Sync, Sync, -languages, Choose language, Choose language, Choose language, -english, English, English, English, -khasi, Khasi, Khasi, Khasi, -hindi, Hindi, Hindi, Hindi, -user-id, Your user ID, User ID, User ID, -save, Save, Save, Save, -back, Back, Back, Back, -off, Off, Off, Off, -villages, Villages, Villages, Villages, -list-empty, List empty, ,, -delete, Delete, ,, -delete-are-you-sure, Are you sure you want to delete this?, ,, -save-are-you-sure, Are you sure you want to save changes?, ,, -quick-name, New person name, ,, -quick-add, Quick add, ,, -find-individual, Find individual, ,, -filter, Filter, ,, -off, Off, Off, Off, -name, Name, ,, -sync-all, Sync me!, ,, -sync-syncall, Sync everything, ,, -export-data, Exporting data, ,, -sync-download, Download main DB, ,, -sync-export, Email main DB, ,, -email-local, Email local DB, ,, -debug, Debug, ,, -sync-back, Back, ,, -sync-prof, Profile, ,, -village-name, Village name, Village name, Village name, -block, Block, Block, Block, -district, District, District, District, -car, Accessible by car, ,, -household-list, Household list, ,, -amenities, Amenities, ,, -school, School, ,, -present, Present, ,, -closest-access, Closest place of access, ,, -house-gps, GPS, ,, -toilet-gps, GPS, ,, -school, School, ,, -school-closest-access, Closest access, ,, -school-gps, GPS, ,, -hospital, Hospital/Health care centre, ,, -hospital-closest-access, Closest access, ,, -hospital-gps, GPS, ,, -post-office, Post Office, ,, -post-office-closest-access, Closest access, ,, -post-office-gps, GPS, ,, -railway-station, Railway station, ,, -railway-station-closest-access, Closest access, ,, -railway-station-gps, GPS, ,, -state-bus-service, Inter-state bus service, ,, -state-bus-service-closest-access, Closest access, ,, -state-bus-service-gps, GPS, ,, -district-bus-service, Inter-village/district bus service, ,, -district-bus-service-closest-access, Closest access, ,, -district-bus-service-gps, GPS, ,, -panchayat, Village Panchayat Office, ,, -panchayat-closest-access, Closest access, ,, -panchayat-gps, GPS, ,, -NGO, Presence of NGO's working with them, ,, -NGO-closest-access, Closest access, ,, -NGO-gps, GPS, ,, -market, Market, ,, -market-closest-access, Closest access, ,, -market-gps, GPS, ,, -household-name, Household name, ,, -default-household-name, A household, ,, -location, House location, ,, -elevation, Elevation, ,, -toilet-location, Toilet location, ,, -children, Children, ,, -male, Male, ,, -female, Female, ,, -num-pots, Number of pots, ,, -adults, Adults, ,, -add-individual, Add individual, ,, -default-individual-name, A person, ,, -default-family-name, A family, ,, -default-photo-id, ???, ,, -name-display, Name, ,, -photo-id-display, Photo ID, ,, -family-display, Family, ,, -details-button, Details, ,, -family-button, Family, ,, -migration-button, Migration, ,, -income-button, Income, ,, -geneaology-button, Geneaology, ,, -social-button, Social, ,, -agreement-button, Agreement, ,, -is-a-child, Child, ,, -change-photo, Change photo, ,, -details-name, Name, ,, -details-photo-id, Photo ID, ,, -details-family, Family, ,, -tribe, Tribe, ,, -sub-tribe, Sub tribe, ,, -khasi, Khasi, ,, -khynriam, Khynriam, ,, -pnar, Pnar, ,, -bhoi, Bhoi, ,, -war, War, ,, -other, Other, ,, -age, Age, ,, -gender, Gender, ,, -education, Education, ,, -illiterate, Illiterate, ,, -literate, Literate, ,, -primary, Primary 1-5, ,, -middle, Middle 6-8, ,, -high, High 9-10, ,, -secondary, Higher Secondary, ,, -university, University, ,, -spouse, Spouse, ,, -change-id, Change, ,, -head-of-house, Head of house, ,, -marital-status, Marital status, ,, -ever-married, Ever married, ,, -currently-married, Currently married, ,, -currently-single, Currently single, ,, -seperated, Seperated/divorced, ,, -times-married, How many times married, ,, -change-spouse, Change/add spouse, ,, -children-living, Living, ,, -children-dead, Dead, ,, -children-together, Living together, ,, -children-apart, Living apart, ,, -residence-after-marriage, Residence after marriage, ,, -birthplace, Birthplace, ,, -spouse-village, Spouses natal village, ,, -num-siblings, Number of living siblings of the same sex born from same mother, ,, -birth-order, Birth order amoung currently living same sex siblings born from same mother, ,, -length-time, Length of time lived in this village (years), ,, -place-of-birth, Place of birth, ,, -num-residence-changes, Number of time place of residence changed since birth, ,, -village-visits-month, Number of times you have visited another village in the last month, ,, -village-visits-year, Number of times you have visited another village in the last year (i.e. betwen last summer and this summer), ,, -occupation, Occupation, ,, -occupation, Occupation, ,, -agriculture, Agriculture, ,, -gathering, Gathering, ,, -labour, Labour, ,, -cows, Cows, ,, -fishing, Fishing, ,, -num-people-in-house, People living in house, ,, -contribute, Contribute to family earnings?, ,, -own-land, Own land?, ,, -rent-land, Rent out your land?, ,, -hire-land, Hire land?, ,, -crops, Crops, ,, -unit, Unit, ,, -quantity, Quantity, ,, -used-or-eaten, Used/Eaten, ,, -sold, Sold, ,, -seed, Seed (hybrid/local), ,, -house-type, House type, ,, -concrete, Concrete, ,, -tin, Tin, ,, -thatched, Thatched, ,, -loan, Outstanding loans, ,, -earning, One day's earnings, ,, -in-the-home, In the home, ,, -radio, Radio, ,, -tv, TV, ,, -mobile, Mobile phone, ,, -visit-market, Tribal market visits, ,, -town-sell, Town or city visits, ,, -default-crop-name, A crop, ,, -crop-name, Crop name, ,, -crop-unit, Crop unit, ,, -crop-used, Used or eaten, ,, -crop-sold, Sold, ,, -crop-seed, Seed, ,, -mother, Mother, ,, -father, Father, ,, -change-mother, Change mother, ,, -change-father, Change father, ,, -alive, Alive, ,, -sex, Sex, ,, -social-type, Type, ,, -friendship, Friendship, ,, -knowledge, Knowledge, ,, -prestige, Prestige, ,, -social-one, One, ,, -social-two, Two, ,, -social-three, Three, ,, -social-four, Four, ,, -social-five, Five, ,, -social-relationship, Relationship, ,, -social-residence, Residence, ,, -social-strength, Strength, ,, -mother, Mother, ,, -father, Father, ,, -sister, Sister, ,, -brother, Brother, ,, -spouse, Spouse, ,, -children, Children, ,, -co-wife, Co-wife, ,, -spouse-mother, Spouse's mother, ,, -spouse-father, Spouse's father, ,, -spouse-brother-wife, Spouse's brother's wife, ,, -spouse-sister-husband, Spouse's sister's husband, ,, -friend, Friend, ,, -neighbour, Neighbour, ,, -same, Same, ,, -daily, Daily, ,, -weekly, Weekly, ,, -monthly, Monthly, ,, -less, Less, ,, +"Code (don't change these)","English","Khasi","Hindi", +"start","Symbai",,, +"next","Next",,, +"yes","Yes",,, +"no","No",,, +"unanswered","Unanswered",,, +"not-set","Not set",,, +"details-next","Next",,, +"family-next","Next",,, +"migration-next","Next",,, +"income-next","Next",,, +"gene-next","Next",,, +"social-next","Next",,, +"friendship-next","Next",,, +"agreement-next","Next",,, +"village"," Village"," ",, +"household"," Household"," ",, +"households"," Households"," ",, +"individual"," Individual"," ",, +"individuals"," Individuals"," ",, +"add-item-to-list",0," ",, +"default-village-name"," New village"," ",, +"title"," Symbai"," Symbai"," Symbai"," " +"sync"," Sync"," Sync"," Sync"," " +"languages"," Choose language"," Choose language"," Choose language"," " +"english"," English"," English"," English"," " +"khasi"," Khasi"," Khasi"," Khasi"," " +"hindi"," Hindi"," Hindi"," Hindi"," " +"user-id"," User ID"," User ID"," User ID"," " +"save"," Save"," Save"," Save"," " +"back"," Back"," Back"," Back"," " +"off"," Off"," Off"," Off"," " +"villages"," Villages"," Villages"," Villages"," " +"list-empty"," List empty"," ",, +"delete"," Delete"," ",, +"delete-are-you-sure"," Are you sure you want to delete this?"," ",, +"save-are-you-sure"," Are you sure you want to save changes?"," ",, +"quick-name"," New person name"," ",, +"quick-add"," Quick add"," ",, +"find-individual"," Find individual"," ",, +"filter"," Filter"," ",, +"filter-switch","Run filter",,, +"off"," Off"," Off"," Off"," " +"name"," Name","Kyrteng",, +"sync-all"," Sync me!"," ",, +"sync-syncall"," Sync everything"," ",, +"export-data"," Exporting data"," ",, +"sync-download"," Download main DB"," ",, +"sync-export"," Email main DB"," ",, +"email-local"," Email local DB"," ",, +"debug"," Debug"," ",, +"sync-back"," Back"," ",, +"sync-prof"," Profile"," ",, +"village-name"," Village name"," Village name"," Village name"," " +"block"," Block"," Block"," Block"," " +"district"," District"," District"," District"," " +"car"," Accessible by car"," ",, +"household-list"," Household list"," ",, +"amenities"," Amenities"," ",, +"school"," School"," ",, +"present"," Present"," ",, +"closest-access"," Closest place of access"," ",, +"house-gps"," GPS"," ",, +"toilet-gps"," GPS"," ",, +"school-in-village","In Village",,, +"school"," School"," ",, +"school-closest-access"," Closest access"," ",, +"school-gps"," GPS"," ",, +"hospital-in-village","In Village",,, +"hospital"," Hospital/Health care centre"," ",, +"hospital-closest-access"," Closest access"," ",, +"hospital-gps"," GPS"," ",, +"Post-office-in-village","In Village",,, +"post-office"," Post Office"," ",, +"post-office-closest-access"," Closest access"," ",, +"post-office-gps"," GPS"," ",, +"railway-station-in-village","In Village",,, +"railway-station"," Railway station"," ",, +"railway-station-closest-access"," Closest access"," ",, +"railway-station-gps"," GPS"," ",, +"State-bus-service-in-village","In Village",,, +"state-bus-service"," Inter-state bus service"," ",, +"state-bus-service-closest-access"," Closest access"," ",, +"state-bus-service-gps"," GPS"," ",, +"District-bus-service-in-village","In Village",,, +"district-bus-service"," Inter-village/district bus service"," ",, +"district-bus-service-closest-access"," Closest access"," ",, +"district-bus-service-gps"," GPS"," ",, +"Panchayat-in-village","In Village",,, +"panchayat"," Village Panchayat Office"," ",, +"panchayat-closest-access"," Closest access"," ",, +"panchayat-gps"," GPS"," ",, +"NGO-in-village","In Village",,, +"NGO"," Presence of NGO's working with them"," ",, +"NGO-closest-access"," Closest access"," ",, +"NGO-gps"," GPS"," ",, +"market-in-village","In Village",,, +"market"," Market"," ",, +"market-closest-access"," Closest access"," ",, +"market-gps"," GPS"," ",, +"household-name"," Household name"," ",, +"default-household-name"," A household"," ",, +"location"," House location"," ",, +"elevation"," Elevation"," ",, +"toilet-location"," Toilet location"," ",, +"children"," Children"," ",, +"male"," Male","Shynrang",, +"female"," Female","Kynthei",, +"num-pots"," Number of pots"," ",, +"adults"," Adults"," ",, +"add-individual"," Add individual"," ",, +"default-individual-name"," A person"," ",, +"default-family-name"," A family"," ",, +"default-photo-id"," ???"," ",, +"name-display"," Name","Kyrteng",, +"photo-id-display"," Photo ID","Nombor dur ID",, +"family-display"," Family","Family/Clan",, +"details-button"," Details"," ",, +"family-button"," Family","Family/Clan",, +"migration-button"," Migration"," ",, +"friendship-button","Friendship",,, +"income-button"," Income"," ",, +"genealogy-button"," Genealogy"," ",, +"social-button"," Social"," ",, +"agreement-button"," Agreement"," ",, +"is-a-child"," Child"," ",, +"change-photo"," Change photo"," ",, +"details-name"," Name","Kyrteng",, +"details-first-name","Name","Kyrteng",, +"details-photo-id"," Photo ID","Nombor dur ID",, +"details-family"," Family"," ",, +"tribe"," Tribe","Jaidbynriew:",, +"sub-tribe"," Sub tribe","Tynrai Jaidbynriew",, +"khasi"," Khasi"," ",, +"khynriam"," Khynriam"," ",, +"pnar"," Pnar"," ",, +"bhoi"," Bhoi"," ",, +"war"," War"," ",, +"other"," Other"," ",, +"age"," Age","Ka rta",, +"gender"," Gender","U/ka",, +"education"," Education","Jingpule",, +"illiterate"," Illiterate","Bym Nang/Bymstad",, +"literate"," Literate","Lah Nang/Lahtip",, +"primary"," Primary 1-5","Biang 1-5",, +"middle"," Middle 6-8","Ba Pdeng 6-8",, +"high"," High 9-10","Lah Khamstad 9-10",, +"secondary"," Higher Secondary","Lah stad",, +"university"," University","La pyndep university",, +"spouse"," Spouse"," ",, +"change-id"," Change"," ",, +"head-of-house"," Head of house"," ",, +"marital-status"," Marital status"," ",, +"ever-married"," Ever married"," ",, +"currently-married"," Currently married"," ",, +"currently-single"," Currently single"," ",, +"seperated"," Seperated/divorced"," ",, +"times-married"," How many times married"," ",, +"change-spouse"," Change/add spouse"," ",, +"children-living"," Living"," ",, +"children-dead"," Dead"," ",, +"children-together"," Living together"," ",, +"children-apart"," Living apart"," ",, +"residence-after-marriage"," Residence after marriage"," ",, +"birthplace"," Birthplace"," ",, +"spouse-village"," Spouses natal village"," ",, +"num-siblings"," Number of living siblings of the same sex born from same mother"," ",, +"birth-order"," Birth order amoung currently living same sex siblings born from same mother"," ",, +"length-time"," Length of time lived in this village (years)"," ",, +"place-of-birth"," Place of birth"," ",, +"num-residence-changes"," Number of time place of residence changed since birth"," ",, +"village-visits-month"," Number of times you have visited another village in the last month"," ",, +"village-visits-year"," Number of times you have visited another village in the last year (i.e. between last summer and this summer)"," ",, +"occupation"," Occupation"," ",, +"occupation"," Occupation"," ",, +"num-people-in-house"," People living in house"," ",, +"contribute"," Do you contribute to the family earnings?"," ",, +"own-land"," Do you own land?"," ",, +"rent-land"," Do you rent out your land?"," ",, +"hire-land"," Do you hire someone else's land to work on?"," ",, +"crops-detail","List the crops you grew last year:",,, +"crops"," Crops"," ",, +"unit"," Unit"," ",, +"quantity"," Quantity"," ",, +"used-or-eaten"," Used/Eaten"," ",, +"sold"," Sold"," ",, +"seed"," Seed (hybrid/local)"," ",, +"house-type"," Type of house"," ",, +"concrete"," Concrete"," ",, +"tin"," Tin"," ",, +"thatched"," Thatched"," ",, +"loan"," Outstanding loans"," ",, +"earning"," How much do you earn for one day's labour?"," ",, +"in-the-home"," In the home"," ",, +"radio"," Radio"," ",, +"tv"," TV"," ",, +"mobile"," Mobile phone"," ",, +"visit-market"," How many times do you visit the tribal market?"," ",, +"town-sell","How many times a month do you visit your nearest city or town to buy or sell something?"," ",, +"default-crop-name"," A crop"," ",, +"crop-name"," Crop name"," ",, +"crop-unit"," Crop unit"," ",, +"crop-used"," Used or eaten"," ",, +"crop-sold"," Sold"," ",, +"crop-seed"," Seed"," ",, +"mother"," Mother"," ",, +"father"," Father"," ",, +"change-mother"," Change mother"," ",, +"change-father"," Change father"," ",, +"alive"," Alive"," ",, +"sex"," Sex"," ",, +"social-type"," Type"," ",, +"friendship"," Friendship"," ",, +"knowledge"," Knowledge"," ",, +"prestige"," Prestige"," ",, +"social-one"," One"," ",, +"social-two"," Two"," ",, +"social-three"," Three"," ",, +"social-four"," Four"," ",, +"social-five"," Five"," ",, +"social-nickname","Name",,, +"social-relationship"," Relation"," ",, +"social-residence"," Residence"," ",, +"social-strength"," Strength"," ",, +"mother"," Mother"," ",, +"father"," Father"," ",, +"sister"," Sister"," ",, +"brother"," Brother"," ",, +"spouse"," Spouse"," ",, +"children"," Children"," ",, +"co-wife"," Co-wife"," ",, +"spouse-mother"," Spouse's mother"," ",, +"spouse-father"," Spouse's father"," ",, +"spouse-brother-wife"," Spouse's brother's wife"," ",, +"spouse-sister-husband"," Spouse's sister's husband"," ",, +"friend"," Friend"," ",, +"neighbour"," Neighbour"," ",, +"same"," Same"," ",, +"daily"," Daily"," ",, +"weekly"," Weekly"," ",, +"monthly"," Monthly"," ",, +"less"," Less"," ",, +"child-name","Name",,, +"child-gender","Gender",,, +"child-age","Age",,, +"child-home","Lives at home",,, +"child-alive","Alive",,, +"default-child-name","A child",,, +"move-button","Move household",,, +"move-household","Pick a new household",,, +"house-id","House ID",,, +"photo-id","Photo ID",,, +"add-are-you-sure","Are you sure you want to add this individual?",,, +"gps-are-you-sure","Are you sure you want to record your current position?",,, +"gps-are-you-sure-2","Please confirm again...",,, +"current-village","Your current village",,, +"num-children","Number of children",,, +"occupation-agriculture","Agriculture",,, +"occupation-gathering","Gathering",,, +"occupation-labour","Labour",,, +"occupation-cows","Cows",,, +"occupation-fishing","Fishing",,, +"occupation-other","Other",,, +"friendship-question","LIST UP TO FIVE PERSONS whom you have really liked to talk to in the last year. They can be of either sex. They can be friends, neighbours, relatives, co-wives; they can live in this village or elsewhere; anyone you like to talk to. ",,, +"prestige-question","LIST UP TO FIVE PERSONS who you think are the most respected in the village: ",,, +"knowledge-question","LIST UP TO FIVE PERSONS who you think are the most knowledgeable in the village:",,, diff --git a/android/assets/translations.scm b/android/assets/translations.scm index 27e3aea35ce4e6b6ebffc5755b4d8a88ce53f900..17ea09e4d71a4b567a3d3cb84422c89cb68b847a 100644 --- a/android/assets/translations.scm +++ b/android/assets/translations.scm @@ -1,259 +1,281 @@ (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 'next (list "Next" )) -(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" "" )) -(list 'family-button (list "Family" "Family/Clan" )) -(list 'migration-button (list "Migration" "" )) -(list 'friendship-button (list "Friendship" )) -(list 'income-button (list "Income" "" )) -(list 'geneaology-button (list "Geneaology" "" )) -(list 'social-button (list "Social" "" )) -(list 'agreement-button (list "Agreement" "" )) -(list 'is-a-child (list "Child" "" )) -(list 'change-photo (list "Change photo" "" )) -(list 'details-name (list "Name" "Kyrteng" )) -(list 'details-first-name (list "Name" "Kyrteng" )) -(list 'details-photo-id (list "Photo ID" "Nombor dur ID" )) -(list 'details-family (list "Family" "" )) -(list 'tribe (list "Tribe" "Jaidbynriew:" )) -(list 'sub-tribe (list "Sub tribe" "Tynrai Jaidbynriew" )) -(list 'khasi (list "Khasi" "" )) -(list 'khynriam (list "Khynriam" "" )) -(list 'pnar (list "Pnar" "" )) -(list 'bhoi (list "Bhoi" "" )) -(list 'war (list "War" "" )) -(list 'other (list "Other" "" )) -(list 'age (list "Age" "Ka rta" )) -(list 'gender (list "Gender" "U/ka" )) -(list 'education (list "Education" "Jingpule" )) -(list 'illiterate (list "Illiterate" "Bym Nang/Bymstad" )) -(list 'literate (list "Literate" "Lah Nang/Lahtip" )) -(list 'primary (list "Primary 1-5" "Biang 1-5" )) -(list 'middle (list "Middle 6-8" "Ba Pdeng 6-8" )) -(list 'high (list "High 9-10" "Lah Khamstad 9-10" )) -(list 'secondary (list "Higher Secondary" "Lah stad" )) -(list 'university (list "University" "La pyndep university" )) -(list 'spouse (list "Spouse" "" )) -(list 'change-id (list "Change" "" )) -(list 'head-of-house (list "Head of house" "" )) -(list 'marital-status (list "Marital status" "" )) -(list 'ever-married (list "Ever married" "" )) -(list 'currently-married (list "Currently married" "" )) -(list 'currently-single (list "Currently single" "" )) -(list 'seperated (list "Seperated/divorced" "" )) -(list 'times-married (list "How many times married" "" )) -(list 'change-spouse (list "Change/add spouse" "" )) -(list 'children-living (list "Living" "" )) -(list 'children-dead (list "Dead" "" )) -(list 'children-together (list "Living together" "" )) -(list 'children-apart (list "Living apart" "" )) -(list 'residence-after-marriage (list "Residence after marriage" "" )) -(list 'birthplace (list "Birthplace" "" )) -(list 'spouse-village (list "Spouses natal village" "" )) -(list 'num-siblings (list "Number of living siblings of the same sex born from same mother" "" )) -(list 'birth-order (list "Birth order amoung currently living same sex siblings born from same mother" "" )) -(list 'length-time (list "Length of time lived in this village (years)" "" )) -(list 'place-of-birth (list "Place of birth" "" )) -(list 'num-residence-changes (list "Number of time place of residence changed since birth" "" )) -(list 'village-visits-month (list "Number of times you have visited another village in the last month" "" )) -(list 'village-visits-year (list "Number of times you have visited another village in the last year (i.e. between last summer and this summer)" "" )) -(list 'occupation (list "Occupation" "" )) -(list 'occupation (list "Occupation" "" )) -(list 'num-people-in-house (list "People living in house" "" )) -(list 'contribute (list "Do you contribute to the family earnings?" "" )) -(list 'own-land (list "Do you own land?" "" )) -(list 'rent-land (list "Do you rent out your land?" "" )) -(list 'hire-land (list "Do you hire someone else's land to work on?" "" )) -(list 'crops-detail (list "List the crops you grew last year:" )) -(list 'crops (list "Crops" "" )) -(list 'unit (list "Unit" "" )) -(list 'quantity (list "Quantity" "" )) -(list 'used-or-eaten (list "Used/Eaten" "" )) -(list 'sold (list "Sold" "" )) -(list 'seed (list "Seed (hybrid/local)" "" )) -(list 'house-type (list "Type of house" "" )) -(list 'concrete (list "Concrete" "" )) -(list 'tin (list "Tin" "" )) -(list 'thatched (list "Thatched" "" )) -(list 'loan (list "Outstanding loans" "" )) -(list 'earning (list "How much do you earn for one day's labour?" "" )) -(list 'in-the-home (list "In the home" "" )) -(list 'radio (list "Radio" "" )) -(list 'tv (list "TV" "" )) -(list 'mobile (list "Mobile phone" "" )) -(list 'visit-market (list "How many times do you visit the tribal market?" "" )) -(list 'town-sell (list "How many times a month do you visit your nearest city or town to buy or sell something?" "" )) -(list 'default-crop-name (list "A crop" "" )) -(list 'crop-name (list "Crop name" "" )) -(list 'crop-unit (list "Crop unit" "" )) -(list 'crop-used (list "Used or eaten" "" )) -(list 'crop-sold (list "Sold" "" )) -(list 'crop-seed (list "Seed" "" )) -(list 'mother (list "Mother" "" )) -(list 'father (list "Father" "" )) -(list 'change-mother (list "Change mother" "" )) -(list 'change-father (list "Change father" "" )) -(list 'alive (list "Alive" "" )) -(list 'sex (list "Sex" "" )) -(list 'social-type (list "Type" "" )) -(list 'friendship (list "Friendship" "" )) -(list 'knowledge (list "Knowledge" "" )) -(list 'prestige (list "Prestige" "" )) -(list 'social-one (list "One" "" )) -(list 'social-two (list "Two" "" )) -(list 'social-three (list "Three" "" )) -(list 'social-four (list "Four" "" )) -(list 'social-five (list "Five" "" )) -(list 'social-nickname (list "Name" )) -(list 'social-relationship (list "Relation" "" )) -(list 'social-residence (list "Residence" "" )) -(list 'social-strength (list "Strength" "" )) -(list 'mother (list "Mother" "" )) -(list 'father (list "Father" "" )) -(list 'sister (list "Sister" "" )) -(list 'brother (list "Brother" "" )) -(list 'spouse (list "Spouse" "" )) -(list 'children (list "Children" "" )) -(list 'co-wife (list "Co-wife" "" )) -(list 'spouse-mother (list "Spouse's mother" "" )) -(list 'spouse-father (list "Spouse's father" "" )) -(list 'spouse-brother-wife (list "Spouse's brother's wife" "" )) -(list 'spouse-sister-husband (list "Spouse's sister's husband" "" )) -(list 'friend (list "Friend" "" )) -(list 'neighbour (list "Neighbour" "" )) -(list 'same (list "Same" "" )) -(list 'daily (list "Daily" "" )) -(list 'weekly (list "Weekly" "" )) -(list 'monthly (list "Monthly" "" )) -(list 'less (list "Less" "" )) -(list 'child-name (list "Name" )) -(list 'child-gender (list "Gender" )) -(list 'child-age (list "Age" )) -(list 'child-home (list "Lives at home" )) -(list 'child-alive (list "Alive" )) -(list 'default-child-name (list "A child" )) -(list 'move-button (list "Move household" )) -(list 'move-household (list "Pick a new household" )) -(list 'house-id (list "House ID" )) -(list 'photo-id (list "Photo ID" )) -(list 'add-are-you-sure (list "Are you sure you want to add this individual?" )) -(list 'gps-are-you-sure (list "Are you sure you want to record your current position?" )) -(list 'gps-are-you-sure-2 (list "Please confirm again..." )) -(list 'current-village (list "Your current village" )) -(list 'num-children (list "Number of children" )) -(list 'occupation-agriculture (list "Agriculture" )) -(list 'occupation-gathering (list "Gathering" )) -(list 'occupation-labour (list "Labour" )) -(list 'occupation-cows (list "Cows" )) -(list 'occupation-fishing (list "Fishing" )) -(list 'occupation-other (list "Other" )) -(list 'friendship-question (list "LIST UP TO FIVE PERSONS whom you have really liked to talk to in the last year. They can be of either sex. They can be friends, neighbours, relatives, co-wives; they can live in this village or elsewhere; anyone you like to talk to." "" )) -(list 'prestige-question (list "LIST UP TO FIVE PERSONS who you think are the most respected in the village:" )) -(list 'knowledge-question (list "LIST UP TO FIVE PERSONS who you think are the most knowledgeable in the village:" )) -)) + (list 'start (list "Symbai" )) + (list 'next (list "Next" )) + (list 'yes (list "Yes" )) + (list 'no (list "No" )) + (list 'not-answered (list "Unanswered" )) + (list 'not-set (list "Not set" )) + (list 'years-old (list " years old")) + (list 'birth-year (list "Birth year")) + (list 'agree-record (list "Record")) + (list 'agree-playback (list "Play")) + (list 'photo-agree-record (list "Record")) + (list 'photo-agree-playback (list "Play")) + (list 'general-agreement-text (list "Blah blah...")) + (list 'photo-agreement-text (list "Blah blah...")) + (list 'village-notes (list "Notes")) + (list 'individual-notes (list "Notes")) + (list 'household-notes (list "Notes")) + (list 'crop-notes (list "Notes")) + (list 'child-notes (list "Notes")) + (list 'details-next (list "Next" )) + (list 'family-next (list "Next" )) + (list 'migration-next (list "Next" )) + (list 'income-next (list "Next" )) + (list 'gene-next (list "Next" )) + (list 'social-next (list "Next" )) + (list 'friendship-next (list "Next" )) + (list 'agreement-next (list "Next" )) + (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 "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 'filter-switch (list "Run 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" "" )) + (list 'family-button (list "Family" "Family/Clan" )) + (list 'migration-button (list "Migration" "" )) + (list 'friendship-button (list "Friendship" )) + (list 'income-button (list "Income" "" )) + (list 'genealogy-button (list "Genealogy" "" )) + (list 'social-button (list "Social" "" )) + (list 'agreement-button (list "Agreement" "" )) + (list 'is-a-child (list "Child" "" )) + (list 'change-photo (list "Change photo" "" )) + (list 'details-name (list "Name" "Kyrteng" )) + (list 'details-first-name (list "Name" "Kyrteng" )) + (list 'details-photo-id (list "Photo ID" "Nombor dur ID" )) + (list 'details-family (list "Family" "" )) + (list 'tribe (list "Tribe" "Jaidbynriew:" )) + (list 'sub-tribe (list "Sub tribe" "Tynrai Jaidbynriew" )) + (list 'khasi (list "Khasi" "" )) + (list 'khynriam (list "Khynriam" "" )) + (list 'pnar (list "Pnar" "" )) + (list 'bhoi (list "Bhoi" "" )) + (list 'war (list "War" "" )) + (list 'other (list "Other" "" )) + (list 'age (list "Age" "Ka rta" )) + (list 'gender (list "Gender" "U/ka" )) + (list 'education (list "Education" "Jingpule" )) + (list 'illiterate (list "Illiterate" "Bym Nang/Bymstad" )) + (list 'literate (list "Literate" "Lah Nang/Lahtip" )) + (list 'primary (list "Primary 1-5" "Biang 1-5" )) + (list 'middle (list "Middle 6-8" "Ba Pdeng 6-8" )) + (list 'high (list "High 9-10" "Lah Khamstad 9-10" )) + (list 'secondary (list "Higher Secondary" "Lah stad" )) + (list 'university (list "University" "La pyndep university" )) + (list 'spouse (list "Spouse" "" )) + (list 'change-id (list "Change" "" )) + (list 'head-of-house (list "Head of house" "" )) + (list 'marital-status (list "Marital status" "" )) + (list 'ever-married (list "Ever married" "" )) + (list 'currently-married (list "Currently married" "" )) + (list 'currently-single (list "Currently single" "" )) + (list 'seperated (list "Seperated/divorced" "" )) + (list 'times-married (list "How many times married" "" )) + (list 'change-spouse (list "Change/add spouse" "" )) + (list 'children-living (list "Living" "" )) + (list 'children-dead (list "Dead" "" )) + (list 'children-together (list "Living together" "" )) + (list 'children-apart (list "Living apart" "" )) + (list 'residence-after-marriage (list "Residence after marriage" "" )) + (list 'birthplace (list "Birthplace" "" )) + (list 'spouse-village (list "Spouses natal village" "" )) + (list 'num-siblings (list "Number of living siblings of the same sex born from same mother" "" )) + (list 'birth-order (list "Birth order amoung currently living same sex siblings born from same mother" "" )) + (list 'length-time (list "Length of time lived in this village (years)" "" )) + (list 'place-of-birth (list "Place of birth" "" )) + (list 'num-residence-changes (list "Number of time place of residence changed since birth" "" )) + (list 'village-visits-month (list "Number of times you have visited another village in the last month" "" )) + (list 'village-visits-year (list "Number of times you have visited another village in the last year (i.e. between last summer and this summer)" "" )) + (list 'occupation (list "Occupation" "" )) + (list 'occupation (list "Occupation" "" )) + (list 'num-people-in-house (list "People living in house" "" )) + (list 'contribute (list "Do you contribute to the family earnings?" "" )) + (list 'own-land (list "Do you own land?" "" )) + (list 'rent-land (list "Do you rent out your land?" "" )) + (list 'hire-land (list "Do you hire someone else's land to work on?" "" )) + (list 'crops-detail (list "List the crops you grew last year:" )) + (list 'crops (list "Crops" "" )) + (list 'unit (list "Unit" "" )) + (list 'quantity (list "Quantity" "" )) + (list 'used-or-eaten (list "Used/Eaten" "" )) + (list 'sold (list "Sold" "" )) + (list 'seed (list "Seed (hybrid/local)" "" )) + (list 'house-type (list "Type of house" "" )) + (list 'concrete (list "Concrete" "" )) + (list 'tin (list "Tin" "" )) + (list 'thatched (list "Thatched" "" )) + (list 'loan (list "Outstanding loans" "" )) + (list 'earning (list "How much do you earn for one day's labour?" "" )) + (list 'in-the-home (list "In the home" "" )) + (list 'radio (list "Radio" "" )) + (list 'tv (list "TV" "" )) + (list 'mobile (list "Mobile phone" "" )) + (list 'visit-market (list "How many times do you visit the tribal market?" "" )) + (list 'town-sell (list "How many times a month do you visit your nearest city or town to buy or sell something?" "" )) + (list 'default-crop-name (list "crop" "" )) + (list 'crop-name (list "Crop name" "" )) + (list 'crop-unit (list "Crop unit" "" )) + (list 'crop-used (list "Used or eaten" "" )) + (list 'crop-sold (list "Sold" "" )) + (list 'crop-seed (list "Seed" "" )) + (list 'mother (list "Mother" "" )) + (list 'father (list "Father" "" )) + (list 'change-mother (list "Change mother" "" )) + (list 'change-father (list "Change father" "" )) + (list 'alive (list "Alive" "" )) + (list 'sex (list "Sex" "" )) + (list 'social-type (list "Type" "" )) + (list 'friendship (list "Friendship" "" )) + (list 'knowledge (list "Knowledge" "" )) + (list 'prestige (list "Prestige" "" )) + (list 'social-one (list "One" "" )) + (list 'social-two (list "Two" "" )) + (list 'social-three (list "Three" "" )) + (list 'social-four (list "Four" "" )) + (list 'social-five (list "Five" "" )) + (list 'social-nickname (list "Name" )) + (list 'social-relationship (list "Relation" "" )) + (list 'social-residence (list "Residence" "" )) + (list 'social-strength (list "Strength" "" )) + (list 'mother (list "Mother" "" )) + (list 'father (list "Father" "" )) + (list 'sister (list "Sister" "" )) + (list 'brother (list "Brother" "" )) + (list 'spouse (list "Spouse" "" )) + (list 'children (list "Children" "" )) + (list 'co-wife (list "Co-wife" "" )) + (list 'spouse-mother (list "Spouse's mother" "" )) + (list 'spouse-father (list "Spouse's father" "" )) + (list 'spouse-brother-wife (list "Spouse's brother's wife" "" )) + (list 'spouse-sister-husband (list "Spouse's sister's husband" "" )) + (list 'friend (list "Friend" "" )) + (list 'neighbour (list "Neighbour" "" )) + (list 'same (list "Same" "" )) + (list 'daily (list "Daily" "" )) + (list 'weekly (list "Weekly" "" )) + (list 'monthly (list "Monthly" "" )) + (list 'less (list "Less" "" )) + (list 'child-name (list "Name" )) + (list 'child-gender (list "Gender" )) + (list 'child-age (list "Age" )) + (list 'child-home (list "Lives at home" )) + (list 'child-alive (list "Alive" )) + (list 'default-child-name (list "child" )) + (list 'move-button (list "Move household" )) + (list 'move-household (list "Pick a new household" )) + (list 'house-id (list "House ID" )) + (list 'photo-id (list "Photo ID" )) + (list 'add-are-you-sure (list "Are you sure you want to add this individual?" )) + (list 'gps-are-you-sure (list "Are you sure you want to record your current position?" )) + (list 'gps-are-you-sure-2 (list "Please confirm again..." )) + (list 'current-village (list "Your current village" )) + (list 'num-children (list "Number of children" )) + (list 'occupation-agriculture (list "Agriculture" )) + (list 'occupation-gathering (list "Gathering" )) + (list 'occupation-labour (list "Labour" )) + (list 'occupation-cows (list "Cows" )) + (list 'occupation-fishing (list "Fishing" )) + (list 'occupation-other (list "Other" )) + (list 'friendship-question (list "LIST UP TO FIVE PERSONS whom you have really liked to talk to in the last year. They can be of either sex. They can be friend, neighbours, relatives, co-wives; they can live in this village or elsewhere; anyone you like to talk to." "" )) + (list 'prestige-question (list "LIST UP TO FIVE PERSONS who you think are the most respected in the village:" )) + (list 'knowledge-question (list "LIST UP TO FIVE PERSONS who you think are the most knowledgeable in the village:" )) + )) diff --git a/android/src/foam/symbai/starwisp.java b/android/src/foam/symbai/starwisp.java index 904d2c1a26364ff81ad849bf98a339a6af9171d1..d62817962f4b53d5276d956db15970d1c48f1607 100644 --- a/android/src/foam/symbai/starwisp.java +++ b/android/src/foam/symbai/starwisp.java @@ -71,7 +71,7 @@ public class starwisp extends StarwispActivity ActivityManager.RegisterActivity("family",FamilyActivity.class); ActivityManager.RegisterActivity("migration",MigrationActivity.class); ActivityManager.RegisterActivity("income",IncomeActivity.class); - ActivityManager.RegisterActivity("geneaology",GeneaologyActivity.class); + ActivityManager.RegisterActivity("genealogy",GenealogyActivity.class); ActivityManager.RegisterActivity("social",SocialActivity.class); ActivityManager.RegisterActivity("friendship",FriendshipActivity.class); ActivityManager.RegisterActivity("individual-chooser",IndividualChooserActivity.class); @@ -96,6 +96,8 @@ public class starwisp extends StarwispActivity File filesdir = new File(m_AppDir+"/files/"); filesdir.mkdirs(); + File backupdir = new File(m_AppDir+"/backup/"); + backupdir.mkdirs(); // build static things m_Scheme = new Scheme(this); diff --git a/eavdb/eavdb.ss b/eavdb/eavdb.ss index bef6aa214fda98456457d92c0dc93962e90d38ad..857931c6b520df443547491aa12f01c745f741b5 100644 --- a/eavdb/eavdb.ss +++ b/eavdb/eavdb.ss @@ -86,3 +86,10 @@ (lambda (i) (get-entity-only db table i kt-list)) (filter-entities db table type filter))) + +;; only return (eg. name and photo) +(define (db-filter-only-inc-deleted db table type filter kt-list) + (map + (lambda (i) + (get-entity-only db table i kt-list)) + (filter-entities-inc-deleted db table type filter))) diff --git a/eavdb/entity-filter.ss b/eavdb/entity-filter.ss index c0e6f2165548855e198c2b221cffdaf61e8e4bfb..797941bb5a260b61cea22732efaf4ca0479a1fd9 100644 --- a/eavdb/entity-filter.ss +++ b/eavdb/entity-filter.ss @@ -86,6 +86,28 @@ (if typed "where e.entity_type = ? order by n.value" "order by n.value"))) +(define (build-query-inc-deleted table filter) + (string-append + (foldl + (lambda (i r) + (let ((var (string-append (filter-key i) "_var"))) + ;; add a query chunk + (string-append + r "join " table "_value_" (filter-type i) " " + "as " var " on " + var ".entity_id = e.entity_id and " var ".attribute_id = '" (filter-key i) "' and " + var ".value " (filter-op i) " ? "))) + + ;; boilerplate query start + (string-append + "select e.entity_id from " table "_entity as e " + ;; order by name + "join " table "_value_varchar " + "as n on n.entity_id = e.entity_id and n.attribute_id = 'name' ") + filter) + "where e.entity_type = ? order by n.value")) + + (define (build-args filter) (map (lambda (i) @@ -93,6 +115,23 @@ filter)) (define (filter-entities db table type filter) + (let ((q (build-query table filter))) + (let ((s (apply + db-select + (append + (list db q) + (build-args filter) + (list type))))) + (msg (db-status db)) + (if (null? s) + '() + (map + (lambda (i) + (vector-ref i 0)) + (cdr s)))))) + +(define (filter-entities-inc-deleted db table type filter) + (let ((q (build-query-inc-deleted table filter))) (let ((s (apply db-select (append @@ -105,4 +144,4 @@ (map (lambda (i) (vector-ref i 0)) - (cdr s))))) + (cdr s)))))) diff --git a/eavdb/entity-insert.ss b/eavdb/entity-insert.ss index 8db868a3cc4db0b5c12c2fce491dace978b93a5e..0a508a79f84a7d3b4b3f33ade844cfbdcb05cf2a 100644 --- a/eavdb/entity-insert.ss +++ b/eavdb/entity-insert.ss @@ -65,7 +65,7 @@ ;; add all the keys (for-each (lambda (ktv) - (insert-value db table id ktv dirty)) + (insert-value db table id ktv (not (zero? dirty)))) ktvlist) (db-exec db "end transaction") diff --git a/eavdb/entity-sync.ss b/eavdb/entity-sync.ss index 419a40f347073612e0fa0c43313280c1e08f72ba..37815ae1e58682a0fd87f503daab7ecc0602fd8a 100644 --- a/eavdb/entity-sync.ss +++ b/eavdb/entity-sync.ss @@ -68,7 +68,8 @@ (define (dirty-entities db table) (let ((de (db-select db (string-append - "select entity_id, entity_type, unique_id, dirty, version from " table "_entity where dirty=1;")))) + "select entity_id, entity_type, unique_id, dirty, version from " + table "_entity where dirty=1 limit 5;")))) (if (null? de) '() (map diff --git a/eavdb/entity-values.ss b/eavdb/entity-values.ss index 58f6af72122df9d47f8491821240ee9988e53232..0b219f2e67a949270e46e427e9199a08c7e8e45d 100644 --- a/eavdb/entity-values.ss +++ b/eavdb/entity-values.ss @@ -88,7 +88,7 @@ ;;(msg ktv) ;;(msg entity-id) (if (null? s) - (insert-value db table entity-id ktv #t) + (insert-value db table entity-id ktv #t) ;; <- don't make dirty!? (db-exec db (string-append "update " table "_value_" (ktv-type ktv) " set value=?, dirty=0 where entity_id = ? and attribute_id = ?") @@ -114,8 +114,8 @@ " where entity_id = ? and attribute_id = ?") entity-id (ktv-key kt)))) (if (null? s) '() - (list (vector-ref (cadr s) 0) - (vector-ref (cadr s) 1))))) + (list (vector-ref (cadr s) 0) + (vector-ref (cadr s) 1))))) (define (clean-value db table entity-id kt) (db-exec db (string-append "update " table "_value_" (ktv-type kt) diff --git a/eavdb/ktv-list.ss b/eavdb/ktv-list.ss index aa5dad404080ca198684eeb1fb02f72199f1d5e4..a7a3303004ee3f9e44395640c46790f417a5ef7e 100644 --- a/eavdb/ktv-list.ss +++ b/eavdb/ktv-list.ss @@ -25,6 +25,13 @@ (ktv-value (car ktv-list))) (else (ktv-get (cdr ktv-list) key)))) +(define (ktv-get-whole ktv-list key) + (cond + ((null? ktv-list) #f) + ((equal? (ktv-key (car ktv-list)) key) + (car ktv-list)) + (else (ktv-get-whole (cdr ktv-list) key)))) + (define (ktv-get-type ktv-list key) (cond ((null? ktv-list) #f) diff --git a/symbaidb/.dump b/symbaidb/.dump new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/symbaidb/AndroidManifest.xml b/symbaidb/AndroidManifest.xml new file mode 100644 index 0000000000000000000000000000000000000000..03892ed33e640be5b61cd7b7853140f8b9da83d6 --- /dev/null +++ b/symbaidb/AndroidManifest.xml @@ -0,0 +1,36 @@ + + + + + + + + + + + + + + + + + + + + + + diff --git a/symbaidb/README.md b/symbaidb/README.md new file mode 100644 index 0000000000000000000000000000000000000000..398a7a54f88b105fd921931da29664b06bf534e0 --- /dev/null +++ b/symbaidb/README.md @@ -0,0 +1,2 @@ +Admin SQLite eavdb editor +========================= diff --git a/symbaidb/ant.properties b/symbaidb/ant.properties new file mode 100644 index 0000000000000000000000000000000000000000..cc9e86900f57ddbea603a74ffa8528c665596a45 --- /dev/null +++ b/symbaidb/ant.properties @@ -0,0 +1,7 @@ +# +# Set the keystore properties for signing the application. +# +#key.store=ushahidi-key.keystore +#key.alias=ushahidi-android +key.store=/home/dave/.keystore +key.alias=release_key diff --git a/symbaidb/assets/.#dbsync.scm b/symbaidb/assets/.#dbsync.scm new file mode 120000 index 0000000000000000000000000000000000000000..747ed92ffbc73e3f0150bfd3a18c3493fca27bd5 --- /dev/null +++ b/symbaidb/assets/.#dbsync.scm @@ -0,0 +1 @@ +dave@fulmar.4670:1404729118 \ No newline at end of file diff --git a/symbaidb/assets/dbsync.scm b/symbaidb/assets/dbsync.scm new file mode 100644 index 0000000000000000000000000000000000000000..e16cd2cd0d64849e6e2399d4b45a26b22d698def --- /dev/null +++ b/symbaidb/assets/dbsync.scm @@ -0,0 +1,1141 @@ +;; Starwisp Copyright (C) 2013 Dave Griffiths +;; +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU Affero General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU Affero General Public License for more details. +;; +;; You should have received a copy of the GNU Affero General Public License +;; along with this program. If not, see . + +;; abstractions for synced databased + +(msg "dbsync.scm") + +(define unset-int 2147483647) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; 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 + +(define (entity-init! db table entity-type ktv-list) + (entity-reset!) + (entity-set! ktv-list) + (set-current! 'db db) + (set-current! 'table table) + (set-current! 'entity-type entity-type)) + + +;; 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-add-value-create! key type value) + (msg "entity-add-value-create!" 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 (entity-get-value key) + (ktv-get (get-current 'entity-values '()) key)) + +(define (check-type type value) + (cond + ((equal? type "varchar") + (string? value)) + ((equal? type "file") + (string? value)) + ((equal? type "int") + (number? value)) + ((equal? type "real") + (number? value)))) + +;; version to check the entity has the key +(define (entity-set-value! key type value) + (when (not (check-type type value)) + (msg "INCORRECT TYPE FOR" key ":" type ":" value)) + + (let ((existing-type (ktv-get-type (get-current 'entity-values '()) key))) + (cond + ((equal? existing-type type) + ;; save straight to local db every time (checks for modification) + (entity-update-single-value! (list key type value)) + ;; then save to memory + (set-current! + 'entity-values + (ktv-set + (get-current 'entity-values '()) + (ktv key type value)))) + ;; + (else + (msg "entity-set-value! - adding new " key "of type" type "to entity") + (entity-add-value-create! key type value)) + ))) + +;; version to check the entity has the key +(define (entity-set-value-mem! key type value) + (when (not (check-type type value)) + (msg "INCORRECT TYPE FOR" key ":" type ":" value)) + + ;; then save to memory + (set-current! + 'entity-values + (ktv-set + (get-current 'entity-values '()) + (ktv key type value)))) + + +(define (date-time->string dt) + (string-append + (number->string (list-ref dt 0)) "-" + (substring (number->string (+ (list-ref dt 1) 100)) 1 3) "-" + (substring (number->string (+ (list-ref dt 2) 100)) 1 3) " " + (substring (number->string (+ (list-ref dt 3) 100)) 1 3) ":" + (substring (number->string (+ (list-ref dt 4) 100)) 1 3) ":" + (substring (number->string (+ (list-ref dt 5) 100)) 1 3))) + +;; build entity from all ktvs, insert to db, return unique_id +(define (entity-record-values!) + (let ((db (get-current 'db #f)) + (table (get-current 'table #f)) + (type (get-current 'entity-type #f))) + ;; standard bits + (let ((r (entity-create! db table type (get-current 'entity-values '())))) + (entity-reset!) r))) + + +(define (entity-create! db table entity-type ktv-list) + ;;(msg "creating:" entity-type ktv-list) + (let ((values + (append + (list + (ktv "user" "varchar" (get-current 'user-id "none")) + (ktv "time" "varchar" (date-time->string (date-time))) + (ktv "lat" "real" (car (get-current 'location '(0 0)))) + (ktv "lon" "real" (cadr (get-current 'location '(0 0)))) + (ktv "deleted" "int" 0)) + ktv-list))) + (let ((r (insert-entity/get-unique + db table entity-type (get-current 'user-id "no id") + values))) + (msg "entity-create: " entity-type) + r))) + + +(define (entity-update-values!) + (let ((db (get-current 'db #f)) + (table (get-current 'table #f))) + ;; 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) + ;; removed due to save button no longer exiting activity - need to keep! + ;;(entity-reset!) + ) + (else + (msg "no values or no id to update as entity:" unique-id "values:" values)))))) + +(define (entity-update-single-value! ktv) + (let ((db (get-current 'db #f)) + (table (get-current 'table #f)) + (unique-id (ktv-get (get-current 'entity-values '()) "unique_id"))) + (cond + ((ktv-eq? (ktv-get-whole (get-current 'entity-values '()) (ktv-key ktv)) ktv) + (msg "eusv: no change for" (ktv-key ktv))) + (unique-id + (update-entity db table (entity-id-from-unique db table unique-id) (list ktv))) + (else + (msg "no values or no id to update as entity:" unique-id "values:" values))))) + + +(define (entity-reset!) + (set-current! 'entity-values '()) + (set-current! 'db "reset") + (set-current! 'table "reset") + (set-current! 'entity-type "reset")) + +(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 + +;; todo - separate logic from gui and stick this in common code +;; then we can unit test this stuff... + +(define url "http://192.168.2.1:8889/symbai?") + +(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)))) + + +;; todo fix all hardcoded paths here +(define (send-files ktvlist) + (foldl + (lambda (ktv r) + (if (equal? (ktv-type ktv) "file") + (begin + (cons (http-upload + (string-append "upload-" (ktv-value ktv)) + "http://192.168.2.1:8889/symbai?fn=upload" + (string-append "/sdcard/symbai/files/" (ktv-value ktv))) + r)) + r)) + '() ktvlist)) + +;; redundant second pass to syncronise files - independant of the +;; rest of the syncing system +(define (sync-files server-list) + (let ((local-list (dir-list "/sdcard/symbai/files/"))) + ;; search for all local files in server list + (crop + (append + (foldl + (lambda (file r) + ;; send files not present + (if (or + (eqv? (string-ref file 0) #\.) + (in-list? file server-list)) + r (cons + (http-upload + (string-append "upload-" file) + "http://192.168.2.1:8889/symbai?fn=upload" + (string-append "/sdcard/symbai/files/" file)) r))) + '() + local-list) + ;; search for all server files in local list + (foldl + (lambda (file r) + ;; request files not present + (if (in-list? file local-list) + r (cons + (http-download + (string-append "download-" file) + (string-append "http://192.168.2.1:8889/files/" file) + (string-append "/sdcard/symbai/files/" file)) r))) + '() + server-list)) + ;; restrict the number of uploads each time round + 2))) + +(define (start-sync-files) + (list + (http-request + (string-append "file-list") + (string-append url "fn=file-list") + (lambda (file-list) + (let ((r (sync-files file-list))) + (when (not (null? r)) + (set-current! 'upload 0) + (debug! "Found a mismatch with files on raspberry pi - fixing...")) + r))))) + + +;; spit all dirty entities to server +(define (spit db table entities) + (foldl + (lambda (e r) + ;;(msg (car (car e))) + (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) + (msg "in spit..." 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))))) + (append + ;; check for file uploads + (if (or (equal? (car v) "updated") + (equal? (car v) "inserted") + (equal? (car v) "match")) + (send-files (cadr e)) ;; takes a ktvlist + '()) + (list + (update-widget 'text-view (get-id "sync-dirty") 'text (build-dirty db))))))) + r)) + '() + entities)) + +;; todo fix all hardcoded paths here +(define (request-files ktvlist) + (foldl + (lambda (ktv r) + (if (equal? (ktv-type ktv) "file") + (begin + (cons (http-download + (string-append "download-" (ktv-value ktv)) + (string-append "http://192.168.2.1:8889/files/" (ktv-value ktv)) + (string-append "/sdcard/symbai/files/" (ktv-value ktv))) + r)) + r)) + '() ktvlist)) + +(msg "suck ent") + +(define (suck-entity-from-server db table unique-id) + ;; 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)) + (unique-id (list-ref entity 1)) + (exists (entity-exists? db table unique-id))) + ;; need to check exists again here, due to delays back and forth + (if (not exists) + (insert-entity-wholesale + db table + (list-ref entity 0) ;; entity-type + 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"))) + (cons + (update-widget 'text-view (get-id "sync-dirty") 'text (build-dirty db)) + (request-files ktvlist)))))) + +(define (build-entity-requests db table version-data) + (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 (and (or (not exists) old) + ;; limit this to 5 a time + (< (length r) 5)) + (cons (suck-entity-from-server db table unique-id) r) + r))) + '() + version-data)) + +(define (mark-unlisted-entities-dirty! db table version-data) + (msg "mark-unlisted...") + ;; load all local entities + (let ((ids (all-unique-ids db table)) + (server-ids (map car version-data))) + ;; look for each one in data + (for-each + (lambda (id) + (when (not (in-list? id server-ids)) + (msg "can't find " id " in server data, marking dirty") + (debug! "Have an entity here not on raspberry pi - marking for upload...") + ;; mark those not present as dirty for next spit cycle + (update-entity-dirtify db table id))) + ids))) + +;; 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 ((new-entity-requests (build-entity-requests db table data))) + (alog "suck-new: marking dirty") + (mark-unlisted-entities-dirty! db table data) + (alog "suck-new: done marking dirty") + (cond + ((null? new-entity-requests) + (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")))) + (else + (debug! (string-append + "Requesting " + (number->string (length new-entity-requests)) " entities")) + (cons + (play-sound "active") + new-entity-requests)))))))) + +(msg "build-dirty defined...") + +(define (build-dirty db) + (let ((sync (get-dirty-stats db "sync")) + (stream (get-dirty-stats db "stream"))) + (string-append + "Sync data: " (number->string (car sync)) "/" (number->string (cadr sync)) " " + "Stream 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" + "symbai-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) + )))))) + + +(define i18n-lang 0) + +(define i18n-text + (list)) + +(define (mtext-lookup id) + (define (_ l) + (cond + ((null? l) (string-append (symbol->string id) " not translated")) + ((eq? (car (car l)) id) + (let ((translations (cadr (car l)))) + (if (<= (length translations) i18n-lang) + (string-append (symbol->string id) " not translated") + (let ((r (list-ref translations i18n-lang))) + (if (or (equal? r "") (equal? r " ")) + (list-ref translations 0) r))))) + (else (_ (cdr l))))) + (_ i18n-text)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (symbol->id id) + (when (not (symbol? id)) + (msg "symbol->id: [" id "] is not a symbol")) + (make-id (symbol->string id))) + +(define (get-symbol-id id) + (when (not (symbol? id)) + (msg "symbol->id: [" id "] is not a symbol")) + (get-id (symbol->string id))) + +(define (mbutton id fn) + (button (symbol->id id) + (mtext-lookup id) + 40 (layout 'fill-parent 'wrap-content -1 'centre 5) fn)) + +(define (mbutton-scale id fn) + (button (symbol->id id) + (mtext-lookup id) + 40 (layout 'fill-parent 'wrap-content 1 'centre 5) fn)) + +(define (mtoggle-button id fn) + (toggle-button (symbol->id id) + (mtext-lookup id) + 30 (layout 'fill-parent 'wrap-content -1 'centre 0) "fancy" + ;; convert to 0/1 for easier db storage + (lambda (v) (fn (if v 1 0))))) + +(define (mtoggle-button-scale id fn) + (toggle-button (symbol->id id) + (mtext-lookup id) + 30 (layout 'fill-parent 'wrap-content 1 'centre 0) "fancy" + (lambda (v) (fn (if v 1 0))))) + +(define (mtext id) + (text-view (symbol->id id) + (mtext-lookup id) + 30 (layout 'wrap-content 'wrap-content -1 'centre 0))) + +(define (mtext-fixed w id) + (text-view (symbol->id id) + (mtext-lookup id) + 30 (layout w 'wrap-content -1 'centre 0))) + +(define (mtext-small id) + (text-view (symbol->id id) + (mtext-lookup id) + 20 (layout 'wrap-content 'wrap-content -1 'centre 0))) + +(define (mtext-scale id) + (text-view (symbol->id id) + (mtext-lookup id) + 30 (layout 'wrap-content 'wrap-content 1 'centre 0))) + +(define (mtitle id) + (text-view (symbol->id id) + (mtext-lookup id) + 50 (layout 'fill-parent 'wrap-content -1 'centre 5))) + +(define (mtitle-scale id) + (text-view (symbol->id id) + (mtext-lookup id) + 50 (layout 'fill-parent 'wrap-content 1 'centre 5))) + +(define (medit-text id type fn) + (linear-layout + (make-id (string-append (symbol->string id) "-container")) + 'vertical + (layout 'fill-parent 'wrap-content 1 'centre 20) + (list 0 0 0 0) + (list + (text-view 0 (mtext-lookup id) + 30 (layout 'wrap-content 'wrap-content -1 'centre 0)) + (edit-text (symbol->id id) "" 30 type + (layout 'fill-parent 'wrap-content -1 'centre 0) + fn)))) + +(define (medit-text-scale id type fn) + (linear-layout + (make-id (string-append (symbol->string id) "-container")) + 'vertical + (layout 'fill-parent 'wrap-content 1 'centre 20) + (list 0 0 0 0) + (list + (text-view 0 (mtext-lookup id) + 30 (layout 'wrap-content 'wrap-content 1 'centre 0)) + (edit-text (symbol->id id) "" 30 type + (layout 'fill-parent 'wrap-content 1 'centre 0) + fn)))) + +(define (medit-text-large id type fn) + (linear-layout + (make-id (string-append (symbol->string id) "-container")) + 'vertical + (layout 'fill-parent 'wrap-content 1 'centre 20) + (list 0 0 0 0) + (list + (text-view 0 (mtext-lookup id) + 30 (layout 'wrap-content 'wrap-content -1 'centre 0)) + (edit-text (symbol->id id) "" 30 type + (layout 'fill-parent 300 -1 'left 0) + fn)))) + + +(define (mspinner id types fn) + (vert + (text-view (symbol->id id) + (mtext-lookup id) + 30 (layout 'wrap-content 'wrap-content 1 'centre 0)) + (spinner (make-id (string-append (symbol->string id) "-spinner")) + (map mtext-lookup types) + (layout 'wrap-content 'wrap-content 1 'centre 0) + (lambda (c) (fn c))))) + +(define (mspinner-other id types fn) + (linear-layout + (make-id (string-append (symbol->string id) "-container")) + 'horizontal + (layout 'fill-parent 'wrap-content 1 'centre 5) + (list 0 0 0 0) + (list + (vert + (text-view (symbol->id id) + (mtext-lookup id) + 30 (layout 'wrap-content 'wrap-content 1 'centre 10)) + (spinner (make-id (string-append (symbol->string id) "-spinner")) + (map mtext-lookup types) + (layout 'wrap-content 'wrap-content 1 'centre 0) + (lambda (c) + ;; dont call if set to "other" + (if (< c (- (length types) 1)) + (fn c) + '())))) + (vert + (mtext-scale 'other) + (edit-text (make-id (string-append (symbol->string id) "-edit-text")) + "" 30 "normal" + (layout 'fill-parent 'wrap-content 1 'centre 0) + (lambda (t) (fn t))))))) + +(define (mspinner-other-vert id text-id types fn) + (linear-layout + 0 'vertical + (layout 'fill-parent 'wrap-content 1 'centre 5) + (list 0 0 0 0) + (list + (text-view (symbol->id id) + (mtext-lookup text-id) + 30 (layout 'wrap-content 'wrap-content 1 'centre 5)) + (spinner (make-id (string-append (symbol->string id) "-spinner")) + (map mtext-lookup types) + (layout 'wrap-content 'wrap-content 1 'centre 0) + (lambda (c) + ;; dont call if set to "other" + (if (< c (- (length types) 1)) + (fn c) '()))) + (mtext-scale 'other) + (edit-text (make-id (string-append (symbol->string id) "-edit-text")) + "" 30 "normal" + (layout 'fill-parent 'wrap-content 1 'centre 0) + (lambda (t) (fn t)))))) + + +(define (mclear-toggles id-list) + (map + (lambda (id) + (update-widget 'toggle-button (get-id id) 'checked 0)) + id-list)) + +(define (mclear-toggles-not-me me id-list) + (foldl + (lambda (id r) + (if (equal? me id) + r (cons (update-widget 'toggle-button (get-id id) 'checked 0) r))) + '() id-list)) + +(define (image-invalid? image-name) + (or (null? image-name) + (not image-name) + (equal? image-name "none") + (equal? image-name ""))) + +;; fill out the widget from the current entity in the memory store +;; dispatches based on widget type +(define (mupdate widget-type id-symbol key) + (cond + ((or (eq? widget-type 'edit-text) (eq? widget-type 'text-view)) + (let ((v (entity-get-value key))) + (update-widget widget-type (get-symbol-id id-symbol) 'text + ;; hide -1 as it represents unset + (if (and (number? v) (eqv? v -1)) + "" v)))) + ((eq? widget-type 'toggle-button) + (update-widget widget-type (get-symbol-id id-symbol) 'checked + (entity-get-value key))) + ((eq? widget-type 'image-view) + (let ((image-name (entity-get-value key))) + (if (image-invalid? image-name) + (update-widget widget-type (get-symbol-id id-symbol) 'image "face") + (update-widget widget-type (get-symbol-id id-symbol) 'external-image + (string-append dirname "files/" image-name))))) + (else (msg "mupdate-widget unhandled widget type" widget-type)))) + +(define (spinner-choice l i) + (if (number? i) + (symbol->string (list-ref l i)) + i)) + +(define (mupdate-spinner id-symbol key choices) + (let* ((val (entity-get-value key))) + (if (not val) + (update-widget 'spinner + (get-id (string-append (symbol->string id-symbol) "-spinner")) + 'selection 0) + (let ((index (index-find (string->symbol val) choices))) + (if index + (update-widget 'spinner + (get-id (string-append (symbol->string id-symbol) "-spinner")) + 'selection index) + (begin + (msg "spinner item in db " val " not found in list of items") + (update-widget 'spinner + (get-id (string-append (symbol->string id-symbol) "-spinner")) + 'selection 0))))))) + +(define (mupdate-spinner-other id-symbol key choices) + (let* ((val (entity-get-value key))) + (if (not val) + (list (update-widget 'spinner + (get-id (string-append (symbol->string id-symbol) "-spinner")) + 'selection 0)) + (let ((index (index-find (string->symbol val) choices))) + (if index + (list (update-widget 'spinner + (get-id (string-append (symbol->string id-symbol) "-spinner")) + 'selection index)) + (list + (update-widget 'spinner + (get-id (string-append (symbol->string id-symbol) "-spinner")) + 'selection (- (length choices) 1)) + (update-widget 'edit-text + (get-id (string-append (symbol->string id-symbol) "-edit-text")) + 'text val))))))) + +;;;; +;; (y m d h m s) +(define (date-minus-months d ms) + (let ((year (list-ref d 0)) + (month (- (list-ref d 1) 1))) + (let ((new-month (- month ms))) + (list + (if (< new-month 0) (- year 1) year) + (+ (if (< new-month 0) (+ new-month 12) new-month) 1) + (list-ref d 2) + (list-ref d 3) + (list-ref d 4) + (list-ref d 5))))) + +(define (do-gps display-id key-prepend) + (list + (alert-dialog + "gps-check" + (mtext-lookup 'gps-are-you-sure) + (lambda (v) + (cond + ((eqv? v 1) + (list + (alert-dialog + "gps-check2" + (mtext-lookup 'gps-are-you-sure-2) + (lambda (v) + (cond + ((eqv? v 1) + (let ((loc (get-current 'location '(0 0)))) + (entity-set-value! (string-append key-prepend "-lat") "real" (car loc)) + (entity-set-value! (string-append key-prepend "-lon") "real" (cadr loc)) + (list + (update-widget + 'text-view + (get-id (string-append (symbol->string display-id) "-lat")) + 'text + (number->string (car loc))) + (update-widget + 'text-view + (get-id (string-append (symbol->string display-id) "-lon")) + 'text + (number->string (cadr loc)))))) + (else '())))))) + (else '())))))) + +(define (mupdate-gps display-id key-prepend) + (let ((lat (entity-get-value (string-append key-prepend "-lat"))) + (lon (entity-get-value (string-append key-prepend "-lon")))) + (if (or (not lat) (not lon)) + (list + (update-widget + 'text-view (get-id (string-append (symbol->string display-id) "-lat")) + 'text "O") + (update-widget + 'text-view (get-id (string-append (symbol->string display-id) "-lon")) + 'text "0")) + (list + (update-widget + 'text-view (get-id (string-append (symbol->string display-id) "-lat")) + 'text (number->string lat)) + (update-widget + 'text-view (get-id (string-append (symbol->string display-id) "-lon")) + 'text (number->string lon)))))) + + +;; a standard builder for list widgets of entities and a +;; make new button, to add defaults to the list +(define (build-list-widget db table title title-ids entity-type edit-activity parent-fn ktv-default-fn) + (vert-colour + colour-two + (horiz + (mtitle-scale title) + (button + (make-id (string-append (symbol->string title) "-add")) + (mtext-lookup 'add-item-to-list) + 40 (layout 100 'wrap-content 1 'centre 5) + (lambda () + (entity-create! + db table entity-type + (ktvlist-merge + (ktv-default-fn) + (list (ktv "parent" "varchar" (parent-fn))))) + (list (update-list-widget db table title-ids entity-type edit-activity (parent-fn)))))) + (linear-layout + (make-id (string-append entity-type "-list")) + 'vertical + (layout 'fill-parent 'wrap-content 1 'centre 20) + (list 0 0 0 0) + (list)))) + +(define (make-list-widget-title e title-ids) + (if (eqv? (length title-ids) 1) + (ktv-get e (car title-ids)) + (string-append + (ktv-get e (car title-ids)) "\n" + (foldl + (lambda (id r) + (if (equal? r "") + (ktv-get e id) + (string-append r " " (ktv-get e id)))) + "" (cdr title-ids))))) + +;; pull db data into list of button widgets +(define (update-list-widget db table title-ids entity-type edit-activity parent) + (let ((search-results + (if parent + (db-filter-only db table entity-type + (list (list "parent" "varchar" "=" parent)) + (map + (lambda (id) + (list id "varchar")) + title-ids)) + (db-all db table entity-type)))) + (update-widget + 'linear-layout + (get-id (string-append entity-type "-list")) + 'contents + (if (null? search-results) + (list (mtext 'list-empty)) + (map + (lambda (e) + (button + (make-id (string-append "list-button-" (ktv-get e "unique_id"))) + (make-list-widget-title e title-ids) + 30 (layout 'fill-parent 'wrap-content 1 'centre 5) + (lambda () + (list (start-activity edit-activity 0 (ktv-get e "unique_id")))))) + search-results))))) + +(define (delete-button) + (mbutton + 'delete + (lambda () + (list + (alert-dialog + "delete-check" + (mtext-lookup 'delete-are-you-sure) + (lambda (v) + (cond + ((eqv? v 1) + (entity-set-value! "deleted" "int" 1) + (entity-update-values!) + (list (finish-activity 1))) + (else + (list))))))))) + +(define (build-array-from-names db table entity-type) + (map + (lambda (e) + (list (ktv-get e "name") + (ktv-get e "unique_id"))) + (db-filter-only db table entity-type + (list) + (list (list "name" "varchar"))))) + +(define (find-index-from-name-array arr unique-id) + (define (_ l i) + (cond + ((null? l) #f) + ((equal? unique-id (cadr (car l))) i) + (else (_ (cdr l) (+ i 1))))) + (_ arr 0)) + + + + +(define (simpsons-village db table default-ktvlist) + (entity-create! db table "village" + (ktvlist-merge + default-ktvlist + (list + (ktv "name" "varchar" (string-append "Village-" (number->string (random 1000)))) + (ktv "block" "varchar" (word-gen)) + (ktv "district" "varchar" (word-gen)) + (ktv "car" "int" (random 2)))))) + +(define (simpsons-household db table parent default-ktvlist) + (entity-create! db table "household" + (ktvlist-merge + default-ktvlist + (list + (ktv "name" "varchar" (string-append "Household-" (number->string (random 1000)))) + (ktv "num-pots" "int" (random 10)) + (ktv "parent" "varchar" parent))))) + +(define (simpsons-individual db table parent default-ktvlist) + (let ((n (random 1000))) + (entity-create! db table "individual" + (ktvlist-merge + default-ktvlist + (append + (list (ktv "parent" "varchar" parent)) + (choose + (list + (list + (ktv "name" "varchar" + (string-append "Abe-" (number->string n))) + (ktv "gender" "varchar" "male") + (ktv "photo" "file" "abe.jpg")) + (list + (ktv + "name" "varchar" (string-append "Akira-" (number->string n))) + (ktv "gender" "varchar" "male") + (ktv "photo" "file" "akira.jpg")) + (list + (ktv + "name" "varchar" (string-append "Apu-" (number->string n))) + (ktv "gender" "varchar" "male") + (ktv "photo" "file" "apu.jpg")) + (list + (ktv + "name" "varchar" (string-append "Barney-" (number->string n))) + (ktv "gender" "varchar" "male") + (ktv "photo" "file" "barney.jpg")) + (list + (ktv + "name" "varchar" (string-append "Bart-" (number->string n))) + (ktv "gender" "varchar" "male") + (ktv "photo" "file" "bartsimpson.jpg")) + (list + (ktv + "name" "varchar" (string-append "Billy-" (number->string n))) + (ktv "gender" "varchar" "male") + (ktv "photo" "file" "billy.jpg")) + (list + (ktv + "name" "varchar" (string-append "Carl-" (number->string n))) + (ktv "gender" "varchar" "male") + (ktv "photo" "file" "carl.jpg")) + (list + (ktv + "name" "varchar" (string-append "Cletus-" (number->string n))) + (ktv "gender" "varchar" "male") + (ktv "photo" "file" "cletus.jpg")) + (list + (ktv + "name" "varchar" (string-append "ComicBookGuy-" (number->string n))) + (ktv "gender" "varchar" "male") + (ktv "photo" "file" "comicbookguy.jpg")) + (list + (ktv + "name" "varchar" (string-append "Homer-" (number->string n))) + (ktv "gender" "varchar" "male") + (ktv "photo" "file" "homersimpson.jpg")) + (list + (ktv + "name" "varchar" (string-append "Jasper-" (number->string n))) + (ktv "gender" "varchar" "male") + (ktv "photo" "file" "jasper.jpg")) + (list + (ktv + "name" "varchar" (string-append "Kent-" (number->string n))) + (ktv "gender" "varchar" "male") + (ktv "photo" "file" "kentbrockman.jpg")) + (list + (ktv + "name" "varchar" (string-append "Kodos-" (number->string n))) + (ktv "gender" "varchar" "male") + (ktv "photo" "file" "kodos.jpg")) + (list + (ktv + "name" "varchar" (string-append "Lenny-" (number->string n))) + (ktv "gender" "varchar" "male") + (ktv "photo" "file" "lenny.jpg")) + (list + (ktv + "name" "varchar" (string-append "Lisa-" (number->string n))) + (ktv "gender" "varchar" "female") + (ktv "photo" "file" "lisasimpson.jpg")) + (list + (ktv + "name" "varchar" (string-append "Marge-" (number->string n))) + (ktv "gender" "varchar" "female") + (ktv "photo" "file" "margesimpson.jpg")) + (list + (ktv + "name" "varchar" (string-append "Martin-" (number->string n))) + (ktv "gender" "varchar" "male") + (ktv "photo" "file" "martinprince.jpg")) + (list + (ktv + "name" "varchar" (string-append "Milhouse-" (number->string n))) + (ktv "gender" "varchar" "male") + (ktv "photo" "file" "milhouse.jpg")) + (list + (ktv + "name" "varchar" (string-append "MrBurns-" (number->string n))) + (ktv "gender" "varchar" "male") + (ktv "photo" "file" "mrburns.jpg")) + (list + (ktv + "name" "varchar" (string-append "Ned-" (number->string n))) + (ktv "gender" "varchar" "male") + (ktv "photo" "file" "nedflanders.jpg")) + (list + (ktv + "name" "varchar" (string-append "Nelson-" (number->string n))) + (ktv "gender" "varchar" "male") + (ktv "photo" "file" "nelson.jpg")) + (list + (ktv + "name" "varchar" (string-append "Otto-" (number->string n))) + (ktv "gender" "varchar" "male") + (ktv "photo" "file" "otto.jpg")) + (list + (ktv + "name" "varchar" (string-append "Ralph-" (number->string n))) + (ktv "gender" "varchar" "male") + (ktv "photo" "file" "ralphwiggum.jpg")) + (list + (ktv + "name" "varchar" (string-append "Santaslittlehelper-" (number->string n))) + (ktv "gender" "varchar" "male") + (ktv "photo" "file" "santaslittlehelper.jpg")) + (list + (ktv + "name" "varchar" (string-append "SideshowBob-" (number->string n))) + (ktv "gender" "varchar" "male") + (ktv "photo" "file" "sideshowbob.jpg"))))))))) + +(define (looper! n fn) + (when (not (zero? n)) + (fn n) + (looper! (- n 1) fn))) + +(define (build-test! db table village-ktvlist household-ktvlist individual-ktvlist) + (looper! + 1 + (lambda (i) + (msg "making village" i) + (let ((village (simpsons-village db table village-ktvlist))) + (looper! + 15 + (lambda (i) + (alog "household") + (msg "making household" i) + (let ((household (simpsons-household db table village household-ktvlist))) + (looper! + (+ 2 (random 5)) + (lambda (i) + (msg "making individual" i) + (simpsons-individual db table household individual-ktvlist)))))))))) + + +(define (mangle-test! db table entities) + (define (_ n) + (when (not (zero? n)) + (let ((type (choose entities))) + (msg type) + (let ((entities (all-entities db table type))) + (msg "entities:" entities) + (when (not (null? entities)) + (let ((id (choose entities))) + (msg "entity id:" id) + (let ((ktv-list (get-entity db table id))) + (when (not (null? ktv-list)) + (entity-init! db table type ktv-list) + (for-each + (lambda (ktv) + (when (and + (not (equal? (ktv-key ktv) "deleted")) + (not (equal? (ktv-key ktv) "unique_id")) + (not (equal? (ktv-key ktv) "parent")) + (eqv? (random 10) 0)) + (if (equal? (ktv-type ktv) "varchar") + (entity-set-value! (ktv-key ktv) (ktv-type ktv) + (string-append + (get-current 'user-id "noid") + (random-value-for-type (ktv-type ktv)))) + (entity-set-value! (ktv-key ktv) (ktv-type ktv) + (random-value-for-type (ktv-type ktv)))))) + ktv-list) + (msg "modifying" type id) + (entity-update-values!)) + ))))) + (_ (- n 1)))) + (_ (random 10))) diff --git a/symbaidb/assets/eavdb b/symbaidb/assets/eavdb new file mode 120000 index 0000000000000000000000000000000000000000..15ce6c8adfe1ba41f962d1c9fd12897fb47606e6 --- /dev/null +++ b/symbaidb/assets/eavdb @@ -0,0 +1 @@ +../../eavdb/ \ No newline at end of file diff --git a/symbaidb/assets/eavdb.scm b/symbaidb/assets/eavdb.scm new file mode 100644 index 0000000000000000000000000000000000000000..578e7c170c2cf2c55ff45273b98f8fe3b52f7af0 --- /dev/null +++ b/symbaidb/assets/eavdb.scm @@ -0,0 +1,765 @@ +;; MongooseWeb Copyright (C) 2013 Dave Griffiths +;; +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU Affero General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU Affero General Public License for more details. +;; +;; You should have received a copy of the GNU Affero General Public License +;; along with this program. If not, see . + +;; android/racket stuff +(define db-select db-exec) + +;; racket +;(define db-exec exec/ignore) +;(define db-select select) +;(define db-insert insert) +;(define (db-status) "") +;(define (time) (list 0 0)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; entity-attribut-value system for sqlite +;; + +;; create eav tables (add types as required) +(define (setup db table) + (db-exec db (string-append "create table " table "_entity ( entity_id integer primary key autoincrement, entity_type varchar(256), unique_id varchar(256), dirty integer, version integer)")) + (db-exec db (string-append "create table " table "_attribute ( id integer primary key autoincrement, attribute_id varchar(256), entity_type varchar(256), attribute_type varchar(256))")) + (db-exec db (string-append "create table " table "_value_varchar ( id integer primary key autoincrement, entity_id integer, attribute_id varchar(255), value varchar(4096), dirty integer, version integer)")) + (db-exec db (string-append "create table " table "_value_int ( id integer primary key autoincrement, entity_id integer, attribute_id varchar(255), value integer, dirty integer, version integer)")) + (db-exec db (string-append "create table " table "_value_real ( id integer primary key autoincrement, entity_id integer, attribute_id varchar(255), value real, dirty integer, version integer)")) + (db-exec db (string-append "create table " table "_value_file ( id integer primary key autoincrement, entity_id integer, attribute_id varchar(255), value varchar(4096), dirty integer, version integer)"))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; basic key/type/value structure +;; used for all data internally, and maps to the eavdb types + +(define (ktv key type value) (list key type value 0)) +(define (ktv-with-version key type value version) (list key type value version)) +(define (ktv-create key type value) (list key type value 0)) +(define ktv-key car) +(define ktv-type cadr) +(define ktv-value caddr) +(define (ktv-version ktv) (list-ref ktv 3)) + +(define (ktv-eq? a b) + (and + (equal? (ktv-key a) (ktv-key b)) + (equal? (ktv-type a) (ktv-type b)) + (cond + ((or + (equal? (ktv-type a) "int") + (equal? (ktv-type a) "real")) + (eqv? (ktv-value a) (ktv-value b))) + ((or + (equal? (ktv-type a) "varchar") + (equal? (ktv-type a) "file")) + (equal? (ktv-value a) (ktv-value b))) + (else + (msg "unsupported ktv type in ktv-eq?: " (ktv-type a)) + #f)))) + +;; replace or insert a ktv +(define (ktvlist-replace ktv ktvlist) + (cond + ((null? ktvlist) + (list ktv)) + ((equal? (ktv-key (car ktvlist)) (ktv-key ktv)) + (cons ktv (cdr ktvlist))) + (else (cons (car ktvlist) (ktvlist-replace ktv (cdr ktvlist)))))) + +(define (ktvlist-merge a b) + (foldl + (lambda (ktv r) + (ktvlist-replace ktv r)) + a b)) + +;; stringify based on type (for url) +(define (stringify-value ktv) + (cond + ((null? (ktv-value ktv)) "NULL") + ((equal? (ktv-type ktv) "varchar") (string-append "'" (ktv-value ktv) "'")) + (else + (if (not (string? (ktv-value ktv))) + (number->string (ktv-value ktv)) + (ktv-value ktv))))) + +;; stringify based on type (for url) +(define (stringify-value-url ktv) + (cond + ((null? (ktv-value ktv)) "NULL") + ((equal? (ktv-type ktv) "varchar") (ktv-value ktv)) + (else + (if (not (string? (ktv-value ktv))) + (number->string (ktv-value ktv)) + (ktv-value ktv))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; 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)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; putting data in + +;; get the type from the attribute table with an entity/key +(define (get-attribute-type db table entity-type key) + (let ((sql (string-append + "select attribute_type from " table + "_attribute where entity_type = ? and attribute_id = ?"))) + (select-first db sql entity-type key))) + +;; search for a type and add it if it doesn't exist +(define (find/add-attribute-type db table entity-type key type) + (let ((t (get-attribute-type db table entity-type key))) + ;; add and return passed in type if not exist + (cond + ((null? t) + (msg "adding new attribute for" entity-type " called " key " of type " type) + (db-insert + db (string-append "insert into " table "_attribute values (null, ?, ?, ?)") + key entity-type type) + type) + (else + (cond + ((equal? type t) t) + (else + (msg "type has changed for" entity-type key "from" t "to" type "???") + ;; wont work + ;; what do we do? + ;; some kind of coercion for existing data??? + type)))))) + +;; low level insert of a ktv +(define (insert-value db table entity-id ktv dirty) + ;; use type to dispatch insert to correct value table + (db-insert db (string-append "insert into " table "_value_" (ktv-type ktv) + " values (null, ?, ?, ?, ?, ?)") + entity-id (ktv-key ktv) (ktv-value ktv) (if dirty 1 0) (ktv-version ktv))) + +(define (get-unique user) + (let ((t (time-of-day))) + (string-append + user "-" (number->string (car t)) ":" (number->string (cadr t))))) + +;; insert an entire entity +(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 + db (string-append + "insert into " table "_entity values (null, ?, ?, ?, ?)") + entity-type unique-id dirty version))) + ;; create the attributes if they are new, and validate them if they exist + (for-each + (lambda (ktv) + (find/add-attribute-type db table entity-type (ktv-key ktv) (ktv-type ktv))) + ktvlist) + ;; add all the keys + (for-each + (lambda (ktv) + (insert-value db table id ktv dirty)) + ktvlist) + id)) + + +;; update the value given an entity type, a attribute type and it's key (= attriute_id) +;; creates the value if it doesn't already exist, updates it otherwise if it's different +(define (update-value db table entity-id ktv) + (let ((s (select-first + db (string-append + "select value from " table "_value_" (ktv-type ktv) " where entity_id = ? and attribute_id = ?") + entity-id (ktv-key ktv)))) + (if (null? s) + (insert-value db table entity-id ktv #t) + ;; only update if they are different + (if (not (ktv-eq? ktv (list (ktv-key ktv) (ktv-type ktv) s))) + (begin + (db-exec + db (string-append "update " table "_value_" (ktv-type ktv) + " set value=?, dirty=1, version=version+1 where entity_id = ? and attribute_id = ?") + (ktv-value ktv) entity-id (ktv-key ktv))) + '())))) ;;(msg "values for" (ktv-key ktv) "are the same (" (ktv-value ktv) "==" s ")"))))) + +;; don't make dirty or update version here +(define (update-value-from-sync db table entity-id ktv) + ;;(msg "update-value-from-sync") + ;;(msg entity-id ktv) + (let ((s (select-first + db (string-append + "select value from " table "_value_" (ktv-type ktv) " where entity_id = ? and attribute_id = ?") + entity-id (ktv-key ktv)))) + (if (null? s) + (insert-value db table entity-id ktv #t) + (begin + ;;(msg "actually updating (fs)" (ktv-key ktv) "to" (ktv-value ktv)) + (db-exec + db (string-append "update " table "_value_" (ktv-type ktv) + " set value=?, dirty=0, version=? where entity_id = ? and attribute_id = ?") + (ktv-value ktv) (ktv-version ktv) entity-id (ktv-key ktv)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; getting data out + +(define (entity-exists? db table unique-id) + (not (null? (select-first + db (string-append + "select * from " table "_entity where unique_id = ?") + unique-id)))) + +(define (get-entity-type db table entity-id) + (select-first + db (string-append + "select entity_type from " table "_entity where entity_id = ?") + entity-id)) + +(define (get-all-entity-types db table) + (cdr (db-select db (string-append "select distinct entity_type from " table "_entity;")))) + +;; get all the (current) attributes for an entity type +(define (get-attribute-ids/types db table entity-type) + (let ((s (db-select + db (string-append + "select * from " table "_attribute where entity_type = ?") + entity-type))) + (if (null? s) '() + (map + (lambda (row) + (list (vector-ref row 1) ;; id + (vector-ref row 3))) ;; type + (cdr s))))) + +;; get the value, dirty and version given an entity type, a attribute type and it's key (= attriute_id) +(define (get-value db table entity-id kt) + (let ((s (db-select + db (string-append "select value, dirty, version from " table "_value_" (ktv-type kt) + " where entity_id = ? and attribute_id = ?") + entity-id (ktv-key kt)))) + (if (null? s) '() + (list (vector-ref (cadr s) 0) + (vector-ref (cadr s) 1) + (vector-ref (cadr s) 2))))) + +;; get an entire entity, as a list of key/value pairs +(define (get-entity-plain db table entity-id) + (let* ((entity-type (get-entity-type db table entity-id))) + (cond + ((null? entity-type) (msg "entity" entity-id "not found!") '()) + (else + (foldl + (lambda (kt r) + (let ((vdv (get-value db table entity-id kt))) + (if (null? vdv) + (begin + ;;(msg "ERROR: get-entity-plain: no value found for " entity-id " " (ktv-key kt)) + r) + (cons (list (ktv-key kt) (ktv-type kt) + (list-ref vdv 0) (list-ref vdv 2)) r)))) + '() + (get-attribute-ids/types db table entity-type)))))) + +;; get an entire entity, as a list of key/value pairs, only dirty values +(define (get-entity-plain-for-sync db table entity-id) + (let* ((entity-type (get-entity-type db table entity-id))) + (cond + ((null? entity-type) (msg "entity" entity-id "not found!") '()) + (else + (foldl + (lambda (kt r) + (let ((vdv (get-value db table entity-id kt))) + (cond + ((null? vdv) + ;;(msg "ERROR: get-entity-plain-for-sync: no value found for " entity-id " " (ktv-key kt)) + r) + ;; only return if dirty + ((not (zero? (cadr vdv))) + (cons + (list (ktv-key kt) (ktv-type kt) (list-ref vdv 0) (list-ref vdv 2)) + r)) + (else r)))) + '() + (get-attribute-ids/types db table entity-type)))))) + +;; get an entire entity, as a list of key/value pairs (includes entity id) +(define (get-entity db table entity-id) + (let ((unique-id (get-unique-id db table entity-id))) + (cons + (list "unique_id" "varchar" unique-id) + (get-entity-plain db table entity-id)))) + +;; like get-entity-plain, but only look for specific key/types - for speed +(define (get-entity-only db table entity-id kt-list) + (let ((unique-id (get-unique-id db table entity-id))) + (cons + (list "unique_id" "varchar" unique-id) + (foldl + (lambda (kt r) + (let ((vdv (get-value db table entity-id kt))) + (if (null? vdv) + (begin + ;;(msg "ERROR: get-entity-plain: no value found for " entity-id " " (ktv-key kt)) + r) + (cons (list (ktv-key kt) (ktv-type kt) + (list-ref vdv 0) (list-ref vdv 2)) r)))) + '() + kt-list)))) + + +(define (all-entities db table type) + (let ((s (db-select + db (string-append "select e.entity_id from " table "_entity as e " + "join " table "_value_varchar " + " as n on n.entity_id = e.entity_id and n.attribute_id = ?" + "left join " table "_value_int " + "as d on d.entity_id = e.entity_id and d.attribute_id = ? " + "where e.entity_type = ? " + "and (d.value='NULL' or d.value is NULL or d.value = 0) " + "order by n.value") + "name" "deleted" type))) + (msg (db-status db)) + (if (null? s) + '() + (map + (lambda (i) + (vector-ref i 0)) + (cdr s))))) + +(define (all-entities-with-parent db table type parent) + (let ((s (db-select + db (string-append "select e.entity_id from " table "_entity as e " + "join " table "_value_varchar " + " as n on n.entity_id = e.entity_id and n.attribute_id = ?" + "join " table "_value_varchar " + " as p on p.entity_id = e.entity_id and p.attribute_id = ?" + "left join " table "_value_int " + "as d on d.entity_id = e.entity_id and d.attribute_id = ? " + "where e.entity_type = ? and " + "p.value = ? and " + "(d.value='NULL' or d.value is NULL or d.value = 0) " + "order by n.value") + "name" "parent" "deleted" type parent))) + (msg (db-status db)) + (if (null? s) + '() + (map + (lambda (i) + (vector-ref i 0)) + (cdr s))))) + + +;; filter is list of (attribute-key type op arg) e.g. ("gender" "varchar" "=" "Female") +;; note: only one filter per key.. + +(define (make-filter k t o a) (list k t o a)) +(define (filter-key f) (list-ref f 0)) +(define (filter-type f) (list-ref f 1)) +(define (filter-op f) (list-ref f 2)) +(define (filter-arg f) (list-ref f 3)) + +(define (merge-filter f fl) + (cond + ((null? fl) (list f)) + ((equal? (filter-key (car fl)) (filter-key f)) + (cons f (cdr fl))) + (else (cons (car fl) (merge-filter f (cdr fl)))))) + +(define (delete-filter key fl) + (cond + ((null? fl) '()) + ((equal? (filter-key (car fl)) key) + (cdr fl)) + (else (cons (car fl) (delete-filter key (cdr fl)))))) + +(define (build-query table filter) + (string-append + (foldl + (lambda (i r) + (let ((var (string-append (filter-key i) "_var"))) + ;; add a query chunk + (string-append + r "join " table "_value_" (filter-type i) " " + "as " var " on " + var ".entity_id = e.entity_id and " var ".attribute_id = '" (filter-key i) "' and " + var ".value " (filter-op i) " ? "))) + + ;; boilerplate query start + (string-append + "select e.entity_id from " table "_entity as e " + ;; order by name + "join " table "_value_varchar " + "as n on n.entity_id = e.entity_id and n.attribute_id = 'name' " + ;; ignore deleted + "join " table "_value_int " + "as d on d.entity_id = e.entity_id and d.attribute_id = 'deleted' and " + "d.value = 0 ") + filter) + "where e.entity_type = ? order by n.value")) + +(define (build-args filter) + (map + (lambda (i) + (filter-arg i)) + filter)) + +(define (filter-entities db table type filter) + (let ((s (apply + db-select + (dbg (append + (list db (build-query table filter)) + (build-args filter) + (list type)))))) + (msg (db-status db)) + (if (null? s) + '() + (map + (lambda (i) + (vector-ref i 0)) + (cdr s))))) + + +(define (validate db) + ;; check attribute for duplicate entity-id/attribute-ids + 0) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; helpers + +(define (ktv-get ktv-list key) + (cond + ((null? ktv-list) #f) + ((equal? (ktv-key (car ktv-list)) key) + (ktv-value (car ktv-list))) + (else (ktv-get (cdr ktv-list) key)))) + +(define (ktv-get-type ktv-list key) + (cond + ((null? ktv-list) #f) + ((equal? (ktv-key (car ktv-list)) key) + (ktv-type (car ktv-list))) + (else (ktv-get-type (cdr ktv-list) key)))) + +(define (ktv-set ktv-list ktv) + (cond + ((null? ktv-list) (list ktv)) + ((equal? (ktv-key (car ktv-list)) (ktv-key ktv)) + (cons ktv (cdr ktv-list))) + (else (cons (car ktv-list) (ktv-set (cdr ktv-list) ktv))))) + +(define (db-all db table type) + (map + (lambda (i) + (get-entity db table i)) + (all-entities db table type))) + +(define (db-with-parent db table type parent) + (map + (lambda (i) + (get-entity db table i)) + (all-entities-with-parent db table type parent))) + +(define (db-filter db table type filter) + (map + (lambda (i) + (get-entity db table i)) + (filter-entities db table type filter))) + +;; only return name and photo +(define (db-filter-only db table type filter kt-list) + (map + (lambda (i) + (get-entity-only db table i kt-list)) + (filter-entities db table type filter))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; updating data + +;; update an entire entity (version incl), via a (possibly partial) list of key/value pairs +(define (update-to-version db table entity-id version ktvlist) + ;; not dirty + (update-entity-values db table entity-id ktvlist #f) + (update-entity-version db table entity-id version)) + +;; auto update version +(define (update-entity db table entity-id ktvlist) + ;; dirty + (update-entity-changed db table entity-id) + (update-entity-values db table entity-id ktvlist #t)) + +(define (clean-value db table entity-id kt) + (db-exec db (string-append "update " table "_value_" (ktv-type kt) + " set dirty=0 where entity_id = ? and attribute_id = ?") + entity-id (ktv-key kt))) + +(define (clean-entity-values db table entity-id) + (let* ((entity-type (get-entity-type db table entity-id))) + (cond + ((null? entity-type) + (msg "clean-entity-values: entity" entity-id "not found!") '()) + (else + (for-each + (lambda (kt) + (clean-value db table entity-id (list (ktv-key kt) (ktv-type kt)))) + (get-attribute-ids/types db table entity-type)))))) + +;; update an entity, via a (possibly partial) list of key/value pairs +;; if dirty is not true, this is coming from a sync +(define (update-entity-values db table entity-id ktvlist dirty) + ;;(msg "update-entity-values") + (let* ((entity-type (get-entity-type db table entity-id))) + (cond + ((null? entity-type) (msg "entity" entity-id "not found!") '()) + (else + ;; update main entity type + (for-each + (lambda (ktv) + (when (not (equal? (ktv-key ktv) "unique_id")) + (find/add-attribute-type db table entity-type (ktv-key ktv) (ktv-type ktv)))) + ktvlist) + (for-each + (lambda (ktv) + ;;(msg ktv) + (when (not (equal? (ktv-key ktv) "unique_id")) + (if dirty + (update-value db table entity-id ktv) + (update-value-from-sync db table entity-id ktv)))) + ktvlist))))) + +;; update or create an entire entity if it doesn't exist +;; will return the new entity id if it's created +(define (update/insert-entity db table entity-type user entity-id ktvlist) + (let* ((entity-type (get-entity-type db table entity-id))) + (cond + ((null? entity-type) + (insert-entity db table entity-type user ktvlist)) + (else + (update-entity db table entity-id ktvlist) + #f)))) + +(define (insert-entity-if-not-exists db table entity-type user entity-id ktvlist) + (let ((found (get-entity-type db table entity-id))) + (if (null? found) + (insert-entity db table entity-type user ktvlist) + #f))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; versioning + +(define (get-entity-version db table entity-id) + (select-first + db (string-append "select version from " table "_entity where entity_id = ?") + entity-id)) + +(define (get-entity-dirty db table entity-id) + (select-first + db (string-append "select dirty from " table "_entity where entity_id = ?") + entity-id)) + +(define (update-entity-changed db table entity-id) + (db-exec + db (string-append + "update " table "_entity set dirty=?, version=version+1 where entity_id = ?") + 1 entity-id)) + +;; set from a sync, so clear dirty - should be anyway +(define (update-entity-version db table entity-id version) + (db-exec + db (string-append + "update " table "_entity set dirty=0, version=? where entity_id = ?") + version entity-id)) + +(define (update-entity-clean db table unique-id) + ;;(msg "cleaning") + ;; clean entity table + (db-exec + db (string-append "update " table "_entity set dirty=? where unique_id = ?") + 0 unique-id) + ;; clean value tables for this entity + ;;(msg "cleaning values") + (clean-entity-values db table (entity-id-from-unique db table unique-id)) ) + +(define (have-dirty? db table) + (not (zero? + (select-first + db (string-append "select count(entity_id) from " table "_entity where dirty=1"))))) + + +(define (get-dirty-stats db table) + (list + (select-first + db (string-append "select count(entity_id) from " table "_entity where dirty=1")) + (select-first + db (string-append "select count(entity_id) from " table "_entity;")))) + + + +(define (dirty-entities db table) + (let ((de (db-select + db (string-append + "select entity_id, entity_type, unique_id, dirty, version from " + table "_entity where dirty=1 limit 5;")))) + ;;(msg de) + (if (null? de) + '() + (map + (lambda (i) + ;;(msg "dirty:" (vector-ref i 2)) + (list + ;; build according to url ([table] entity-type unique-id dirty version) + (cdr (vector->list i)) + (get-entity-plain-for-sync db table (vector-ref i 0)))) + (cdr de))))) + +;; todo: BROKEN... +;; used for sync-all +(define (dirty-and-all-entities db table) + (let ((de (db-select + db (string-append + "select entity_id, entity_type, unique_id, dirty, version from " table "_entity")))) + (if (null? de) + '() + (map + (lambda (i) + (list + ;; build according to url ([table] entity-type unique-id dirty version) + (cdr (vector->list i)) + ;; data entries (todo - only dirty values!)??????????? + (get-entity-plain db table (vector-ref i 0)))) + (cdr de))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; syncing + +(define (stringify-list l) + (foldl + (lambda (i r) + (string-append r " " i)) + "" l)) + +(define (stringify-ktvlist ktvlist) + (foldl + (lambda (i r) + (string-append r " " (ktv-key i) ":" (stringify-value i))) + "" + ktvlist)) + +(define (build-sync-debug db table) + (foldl + (lambda (i r) + (string-append + r "\n" (vector-ref i 0) " " (vector-ref i 1) " " + (stringify-ktvlist (get-entity db table (vector-ref i 0))))) + "" + (cdr (db-select + db (string-append "select * from " table "_entity where dirty=1;"))))) + + +(define (build-sync db table) + (map + (lambda (i) + (list + (vector->list i) + (get-entity db table (vector-ref i 0)))) + (cdr (db-select + db (string-append "select * from " table "_entity where dirty=1;"))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; doing things with unique ids + +(define (entity-id-from-unique db table unique-id) + (select-first + db (string-append "select entity_id from " table "_entity where unique_id = ?") + unique-id)) + +(define (entity-version-from-unique db table unique-id) + (select-first + db (string-append "select version from " table "_entity where unique_id = ?") + unique-id)) + + +(define (get-unique-id db table entity-id) + (select-first + db (string-append + "select unique_id from " table "_entity where entity_id = ?") + entity-id)) + +(define (get-entity-id db table unique-id) + (select-first + db (string-append + "select entity_id from " table "_entity where unique_id = ?") + unique-id)) + +(define (get-entity-by-unique db table unique-id) + (get-entity db table (get-entity-id db table unique-id))) + +(define (get-entity-name db table unique-id) + (ktv-get (get-entity-by-unique 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) "\""))) + "id, " + (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-url ktv) "\"")))) + (vector-ref res 1) ;; unique_id + entity)))) + (csv-titles db table entity-type) + (cdr (db-select + db (string-append + "select entity_id, unique_id from " + table "_entity where entity_type = ?") entity-type)))) diff --git a/symbaidb/assets/eavdb_/eavdb.ss b/symbaidb/assets/eavdb_/eavdb.ss new file mode 100644 index 0000000000000000000000000000000000000000..2015604f12475396128577475dcf07a7e5694d29 --- /dev/null +++ b/symbaidb/assets/eavdb_/eavdb.ss @@ -0,0 +1,81 @@ +#lang racket + +;; Starwisp Copyright (C) 2014 Dave Griffiths +;; +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU Affero General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU Affero General Public License for more details. +;; +;; You should have received a copy of the GNU Affero General Public License +;; along with this program. If not, see . + +;; common code - require and provide ignored on tinyscheme + +(require (planet jaymccarthy/sqlite:5:1/sqlite)) + +(require + "../web/scripts/utils.ss" + "../web/scripts/sql.ss" + "ktv.ss" + "ktv-list.ss" + "entity-values.ss" + "entity-insert.ss" + "entity-get.ss" + "entity-update.ss" + "entity-sync.ss" + "entity-filter.ss") + +(provide (all-defined-out)) + +;; create eav tables (add types as required) +(define (setup db table) + (db-exec db (string-append "create table " table "_entity ( entity_id integer primary key autoincrement, entity_type varchar(256), unique_id varchar(256), dirty integer, version integer)")) + (db-exec db (string-append "create table " table "_attribute ( id integer primary key autoincrement, attribute_id varchar(256), entity_type varchar(256), attribute_type varchar(256))")) + (db-exec db (string-append "create table " table "_value_varchar ( id integer primary key autoincrement, entity_id integer, attribute_id varchar(255), value varchar(4096), dirty integer, version integer)")) + (db-exec db (string-append "create table " table "_value_int ( id integer primary key autoincrement, entity_id integer, attribute_id varchar(255), value integer, dirty integer, version integer)")) + (db-exec db (string-append "create table " table "_value_real ( id integer primary key autoincrement, entity_id integer, attribute_id varchar(255), value real, dirty integer, version integer)")) + (db-exec db (string-append "create table " table "_value_file ( id integer primary key autoincrement, entity_id integer, attribute_id varchar(255), value varchar(4096), dirty integer, version integer)"))) + +(define (db-open db-name) + (cond + ((file-exists? (string->path db-name)) + (display "open existing db")(newline) + (open (string->path db-name))) + (else + (display "making new db")(newline) + (let ((db (open (string->path db-name)))) + ;; todo, dynamically create these tables + (setup db "sync") + (setup db "stream") + db)))) + +(define (validate db) + ;; check attribute for duplicate entity-id/attribute-ids + 0) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; helpers + +(define (db-all db table type) + (map + (lambda (i) + (get-entity db table i)) + (all-entities db table type))) + +(define (db-with-parent db table type parent) + (map + (lambda (i) + (get-entity db table i)) + (all-entities-with-parent db table type parent))) + +(define (db-filter db table type filter) + (map + (lambda (i) + (get-entity db table i)) + (filter-entities db table type filter))) diff --git a/symbaidb/assets/eavdb_/entity-csv.ss b/symbaidb/assets/eavdb_/entity-csv.ss new file mode 100644 index 0000000000000000000000000000000000000000..b9dc3455f15f26882d2e8279886d493a6ab2c8a9 --- /dev/null +++ b/symbaidb/assets/eavdb_/entity-csv.ss @@ -0,0 +1,71 @@ +;; Naked on Pluto Copyright (C) 2010 Aymeric Mansoux, Marloes de Valk, Dave Griffiths +;; +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU Affero General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU Affero General Public License for more details. +;; +;; You should have received a copy of the GNU Affero General Public License +;; along with this program. If not, see . + +#lang scheme + +(require + "../web/scripts/utils.ss" + "../web/scripts/sql.ss" + "ktv.ss" + "ktv-list.ss" + "entity-values.ss" + "entity-get.ss") + +(provide (all-defined-out)) + +(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) "\""))) + "id " + (get-attribute-ids/types db table entity-type))) + +(define (csv db table entity-type) + (foldl + (lambda (res r) + (let ((entity (get-entity-for-csv 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)) + (string-append r ", NULL")) + ;; 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-") + (not (equal? (ktv-value ktv) "none"))) + (let ((name (get-entity-name db "sync" (ktv-value ktv)))) + (if (null? name) + "\"nobody\"" + (string-append r ", \"" name "\"")))) + (else + (string-append r ", \"" (stringify-value-url ktv) "\"")))) + (vector-ref res 1) ;; unique_id + entity)))) + (csv-titles db table entity-type) + (cdr (db-select + db (string-append + "select entity_id, unique_id from " + table "_entity where entity_type = ?") entity-type)))) diff --git a/symbaidb/assets/eavdb_/entity-filter.ss b/symbaidb/assets/eavdb_/entity-filter.ss new file mode 100644 index 0000000000000000000000000000000000000000..2388a6719b7da610ddbe5a7c802d62d18c857da0 --- /dev/null +++ b/symbaidb/assets/eavdb_/entity-filter.ss @@ -0,0 +1,97 @@ +#lang racket + +;; Starwisp Copyright (C) 2014 Dave Griffiths +;; +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU Affero General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU Affero General Public License for more details. +;; +;; You should have received a copy of the GNU Affero General Public License +;; along with this program. If not, see . + +(require + "../web/scripts/utils.ss" + "../web/scripts/sql.ss" + "ktv.ss" + "ktv-list.ss" + "entity-values.ss" + "entity-insert.ss" + "entity-get.ss" + "entity-update.ss") + +(provide (all-defined-out)) + +;; filter is list of (attribute-key type op arg) e.g. ("gender" "varchar" "=" "Female") +;; note: only one filter per key.. + +(define (make-filter k t o a) (list k t o a)) +(define (filter-key f) (list-ref f 0)) +(define (filter-type f) (list-ref f 1)) +(define (filter-op f) (list-ref f 2)) +(define (filter-arg f) (list-ref f 3)) + +(define (merge-filter f fl) + (cond + ((null? fl) (list f)) + ((equal? (filter-key (car fl)) (filter-key f)) + (cons f (cdr fl))) + (else (cons (car fl) (merge-filter f (cdr fl)))))) + +(define (delete-filter key fl) + (cond + ((null? fl) '()) + ((equal? (filter-key (car fl)) key) + (cdr fl)) + (else (cons (car fl) (delete-filter key (cdr fl)))))) + +(define (build-query table filter) + (string-append + (foldl + (lambda (i r) + (let ((var (string-append (filter-key i) "_var"))) + ;; add a query chunk + (string-append + r "join " table "_value_" (filter-type i) " " + "as " var " on " + var ".entity_id = e.entity_id and " var ".attribute_id = '" (filter-key i) "' and " + var ".value " (filter-op i) " ? "))) + + ;; boilerplate query start + (string-append + "select e.entity_id from " table "_entity as e " + ;; order by name + "join " table "_value_varchar " + "as n on n.entity_id = e.entity_id and n.attribute_id = 'name' " + ;; ignore deleted + "join " table "_value_int " + "as d on d.entity_id = e.entity_id and d.attribute_id = 'deleted' and " + "d.value = 0 ") + filter) + "where e.entity_type = ? order by n.value")) + +(define (build-args filter) + (map + (lambda (i) + (filter-arg i)) + filter)) + +(define (filter-entities db table type filter) + (let ((s (apply + db-select + (dbg (append + (list db (build-query table filter)) + (build-args filter) + (list type)))))) + (msg (db-status db)) + (if (null? s) + '() + (map + (lambda (i) + (vector-ref i 0)) + (cdr s))))) diff --git a/symbaidb/assets/eavdb_/entity-get.ss b/symbaidb/assets/eavdb_/entity-get.ss new file mode 100644 index 0000000000000000000000000000000000000000..fd9081c0abc41bbfd47eeda20074cb46101b22e2 --- /dev/null +++ b/symbaidb/assets/eavdb_/entity-get.ss @@ -0,0 +1,178 @@ +#lang racket + +;; Starwisp Copyright (C) 2014 Dave Griffiths +;; +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU Affero General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU Affero General Public License for more details. +;; +;; You should have received a copy of the GNU Affero General Public License +;; along with this program. If not, see . + +(require + "../web/scripts/utils.ss" + "../web/scripts/sql.ss" + "ktv.ss" + "ktv-list.ss" + "entity-values.ss") + +(provide (all-defined-out)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; getting data out + +(define (entity-exists? db table unique-id) + (not (null? (select-first + db (string-append + "select * from " table "_entity where unique_id = ?") + unique-id)))) + +(define (get-entity-type db table entity-id) + (select-first + db (string-append + "select entity_type from " table "_entity where entity_id = ?") + entity-id)) + +(define (get-all-entity-types db table) + (cdr (db-select db (string-append "select distinct entity_type from " table "_entity;")))) + +;; fold over values - fn takes ktv, dirty and accum +(define (fold-entity fn db table entity-id) + (let* ((entity-type (get-entity-type db table entity-id))) + (cond + ((null? entity-type) (msg "entity" entity-id "not found!") '()) + (else + (foldl + (lambda (kt r) + (let ((vd (get-value db table entity-id kt))) + (fn kt vd r))) + '() + (reverse (get-attribute-ids/types db table entity-type))))))) + + +;; get an entire entity, as a list of key/value pairs +(define (get-entity-plain db table entity-id) + (fold-entity + (lambda (kt vd r) + (if (null? vd) + r (cons (ktv (ktv-key kt) (ktv-type kt) (car vd)) r))) + db table entity-id)) + +;; get an entire entity, as a list of key/value pairs, only dirty values +(define (get-entity-plain-for-sync db table entity-id) + (fold-entity + (lambda (kt vd r) + (cond + ((null? vd) r) + ;; only return if dirty + ((zero? (cadr vd)) + (cons + (list (ktv-key kt) (ktv-type kt) (list-ref vd 0)) + r)) + (else r))) + db table entity-id)) + +;; get an entire entity, as a list of key/value pairs maintaining order by filling +;; out null values - only use for csv building +(define (get-entity-for-csv db table entity-id) + (fold-entity + (lambda (kt vd r) + (if (null? vd) + (cons (list (ktv-key kt) (ktv-type kt) (null-value-for-type (ktv-type kt))) r) + (cons (ktv (ktv-key kt) (ktv-type kt) (car vd)) r))) + db table entity-id)) + +;; get an entire entity, as a list of key/value pairs (includes entity id) +(define (get-entity db table entity-id) + (let ((unique-id (get-unique-id db table entity-id))) + (cons + (list "unique_id" "varchar" unique-id) + (get-entity-plain db table entity-id)))) + +(define (all-entities db table type) + (let ((s (db-select + db (string-append "select e.entity_id from " table "_entity as e " + "join " table "_value_varchar " + " as n on n.entity_id = e.entity_id and n.attribute_id = ?" + "left join " table "_value_int " + "as d on d.entity_id = e.entity_id and d.attribute_id = ? " + "where e.entity_type = ? " + "and (d.value='NULL' or d.value is NULL or d.value = 0) " + "order by n.value") + "name" "deleted" type))) + (msg (db-status db)) + (if (null? s) + '() + (map + (lambda (i) + (vector-ref i 0)) + (cdr s))))) + +(define (all-entities-with-parent db table type parent) + (let ((s (db-select + db (string-append "select e.entity_id from " table "_entity as e " + "join " table "_value_varchar " + " as n on n.entity_id = e.entity_id and n.attribute_id = ?" + "join " table "_value_varchar " + " as p on p.entity_id = e.entity_id and p.attribute_id = ?" + "left join " table "_value_int " + "as d on d.entity_id = e.entity_id and d.attribute_id = ? " + "where e.entity_type = ? and " + "p.value = ? and " + "(d.value='NULL' or d.value is NULL or d.value = 0) " + "order by n.value") + "name" "parent" "deleted" type parent))) + (msg (db-status db)) + (if (null? s) + '() + (map + (lambda (i) + (vector-ref i 0)) + (cdr s))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; doing things with unique ids + +(define (entity-id-from-unique db table unique-id) + (select-first + db (string-append "select entity_id from " table "_entity where unique_id = ?") + unique-id)) + +(define (entity-version-from-unique db table unique-id) + (select-first + db (string-append "select version from " table "_entity where unique_id = ?") + unique-id)) + + +(define (get-unique-id db table entity-id) + (select-first + db (string-append + "select unique_id from " table "_entity where entity_id = ?") + entity-id)) + +(define (get-entity-id db table unique-id) + (select-first + db (string-append + "select entity_id from " table "_entity where unique_id = ?") + unique-id)) + +(define (get-entity-by-unique db table unique-id) + (get-entity db table (get-entity-id db table unique-id))) + +(define (get-entity-name db table unique-id) + (ktv-get (get-entity-by-unique 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)) diff --git a/symbaidb/assets/eavdb_/entity-insert.ss b/symbaidb/assets/eavdb_/entity-insert.ss new file mode 100644 index 0000000000000000000000000000000000000000..222cf9ac2eef9e21726811962505b64e8414f4b3 --- /dev/null +++ b/symbaidb/assets/eavdb_/entity-insert.ss @@ -0,0 +1,62 @@ +#lang racket + +;; Starwisp Copyright (C) 2014 Dave Griffiths +;; +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU Affero General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU Affero General Public License for more details. +;; +;; You should have received a copy of the GNU Affero General Public License +;; along with this program. If not, see . + +(require + "../web/scripts/utils.ss" + "../web/scripts/sql.ss" + "ktv.ss" + "ktv-list.ss" + "entity-values.ss") + +(provide (all-defined-out)) + +;; insert an entire entity +(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)) + +(define sema (make-semaphore 1)) + +;; all the parameters - for syncing purposes +(define (insert-entity-wholesale db table entity-type unique-id dirty version ktvlist) + (semaphore-wait sema) + (db-exec db "begin transaction") + (let ((id (db-insert + db (string-append + "insert into " table "_entity values (null, ?, ?, ?, ?)") + entity-type unique-id dirty version))) + + ;; create the attributes if they are new, and validate them if they exist + (for-each + (lambda (ktv) + (find/add-attribute-type db table entity-type (ktv-key ktv) (ktv-type ktv))) + ktvlist) + ;; add all the keys + (for-each + (lambda (ktv) + (insert-value db table id ktv dirty)) + ktvlist) + + (db-exec db "end transaction") + (semaphore-post sema) + + id)) diff --git a/symbaidb/assets/eavdb_/entity-sync.ss b/symbaidb/assets/eavdb_/entity-sync.ss new file mode 100644 index 0000000000000000000000000000000000000000..f1c3f4437343025c85c930a927c5dfcabb03c738 --- /dev/null +++ b/symbaidb/assets/eavdb_/entity-sync.ss @@ -0,0 +1,169 @@ +#lang racket + +;; Starwisp Copyright (C) 2014 Dave Griffiths +;; +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU Affero General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU Affero General Public License for more details. +;; +;; You should have received a copy of the GNU Affero General Public License +;; along with this program. If not, see . + +(require + "../web/scripts/utils.ss" + "../web/scripts/sql.ss" + "ktv.ss" + "ktv-list.ss" + "entity-values.ss" + "entity-insert.ss" + "entity-get.ss" + "entity-update.ss") + +(provide (all-defined-out)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; versioning + +(define (get-entity-version db table entity-id) + (select-first + db (string-append "select version from " table "_entity where entity_id = ?") + entity-id)) + +(define (get-entity-dirty db table entity-id) + (select-first + db (string-append "select dirty from " table "_entity where entity_id = ?") + entity-id)) + +(define (update-entity-clean db table unique-id) + ;;(msg "cleaning") + ;; clean entity table + (db-exec + db (string-append "update " table "_entity set dirty=? where unique_id = ?") + 0 unique-id) + ;; clean value tables for this entity + ;;(msg "cleaning values") + (clean-entity-values db table (entity-id-from-unique db table unique-id)) ) + +(define (get-dirty-stats db table) + (list + (select-first + db (string-append "select count(entity_id) from " table "_entity where dirty=1")) + (select-first + db (string-append "select count(entity_id) from " table "_entity;")))) + +(define (dirty-entities db table) + (let ((de (db-select + db (string-append + "select entity_id, entity_type, unique_id, dirty, version from " table "_entity where dirty=1;")))) + (if (null? de) + '() + (map + (lambda (i) + ;;(msg "dirty-entities") + (list + ;; build according to url ([table] entity-type unique-id dirty version) + (cdr (vector->list i)) + ;; data entries (todo - only dirty values!) + (dbg (get-entity-plain-for-sync db table (vector-ref i 0))))) + (cdr de))))) + +;; todo: BROKEN... +;; used for sync-all +(define (dirty-and-all-entities db table) + (let ((de (db-select + db (string-append + "select entity_id, entity_type, unique_id, dirty, version from " table "_entity")))) + (if (null? de) + '() + (map + (lambda (i) + (list + ;; build according to url ([table] entity-type unique-id dirty version) + (cdr (vector->list i)) + ;; data entries (todo - only dirty values!)??????????? + (get-entity-plain db table (vector-ref i 0)))) + (cdr de))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; syncing + +(define (stringify-list l) + (foldl + (lambda (i r) + (string-append r " " i)) + "" l)) + +(define (stringify-ktvlist ktvlist) + (foldl + (lambda (i r) + (string-append r " " (ktv-key i) ":" (stringify-value i))) + "" + ktvlist)) + +(define (build-sync-debug db table) + (foldl + (lambda (i r) + (string-append + r "\n" (vector-ref i 0) " " (vector-ref i 1) " " + (stringify-ktvlist (get-entity db table (vector-ref i 0))))) + "" + (cdr (db-select + db (string-append "select * from " table "_entity where dirty=1;"))))) + + +(define (build-sync db table) + (map + (lambda (i) + (list + (vector->list i) + (get-entity db table (vector-ref i 0)))) + (cdr (db-select + db (string-append "select * from " table "_entity where dirty=1;"))))) + + +(define (entity-sync-test db table) + + (define e (insert-entity db table "thing" "me" (list (ktv "param1" "varchar" "bob") + (ktv "param2" "int" 30) + (ktv "param3" "real" 3.141) + (ktv "name" "varchar" "name") + (ktv "deleted" "int" 0)))) + + (define e2 (insert-entity db table "thing" "me" + (list (ktv "param1" "varchar" "bob") + (ktv "param2" "int" 30) + (ktv "param3" "real" 3.141) + (ktv "param4" "int" 0)))) + + (update-entity db table e (list (ktv "param1" "varchar" "wotzit") + (ktv "param2" "int" 1))) + (update-entity db table e (list (ktv "param3" "real" 3.3))) + + + ;; test the versioning + (asserteq "dirty flag" (get-entity-dirty db table e) 1) + (asserteq "dirty flag2" (get-entity-dirty db table e2) 1) + (let ((uid (get-unique-id db table e2))) + (update-entity-clean db table uid)) + (asserteq "dirty flag post clean" (get-entity-dirty db table e2) 0) + (asserteq "versioning" (get-entity-version db table e) 2) + (asserteq "dirty flag3" (get-entity-dirty db table e) 1) + (assert "dirty" (> (length (dbg (dirty-entities db table))) 0)) + + (for-each + (lambda (e) + (update-entity-clean + db table + (list-ref (car e) 1))) + (dirty-entities db table)) + + (asserteq "cleaning" (length (dirty-entities db table)) 0) + + ) diff --git a/symbaidb/assets/eavdb_/entity-update.ss b/symbaidb/assets/eavdb_/entity-update.ss new file mode 100644 index 0000000000000000000000000000000000000000..2410a7eebead6344f967ecfcb88c073536e9f15f --- /dev/null +++ b/symbaidb/assets/eavdb_/entity-update.ss @@ -0,0 +1,159 @@ +#lang racket + +;; Starwisp Copyright (C) 2014 Dave Griffiths +;; +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU Affero General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU Affero General Public License for more details. +;; +;; You should have received a copy of the GNU Affero General Public License +;; along with this program. If not, see . + +(require + "../web/scripts/utils.ss" + "../web/scripts/sql.ss" + "ktv.ss" + "ktv-list.ss" + "entity-values.ss" + "entity-get.ss" + "entity-insert.ss") + +(provide (all-defined-out)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; updating data + +(define (update-entity-changed db table entity-id) + (db-exec + db (string-append + "update " table "_entity set dirty=?, version=version+1 where entity_id = ?") + 1 entity-id)) + +(define (update-entity-version db table entity-id version) + (db-exec + db (string-append + "update " table "_entity set dirty=0, version=? where entity_id = ?") + version entity-id)) + +;; update an entire entity (version incl), via a (possibly partial) list of key/value pairs +(define (update-to-version db table entity-id version ktvlist) + ;; not dirty + (update-entity-values db table entity-id ktvlist #f) + (update-entity-version db table entity-id version)) + +;; auto update version +(define (update-entity db table entity-id ktvlist) + ;; dirty + (update-entity-changed db table entity-id) + (update-entity-values db table entity-id ktvlist #t)) + +(define (clean-entity-values db table entity-id) + ;;(msg "clean-entity-values") + (let* ((entity-type (get-entity-type db table entity-id))) + (cond + ((null? entity-type) + (msg "clean-entity-values: entity" entity-id "not found!") '()) + (else + (for-each + (lambda (kt) + ;;(msg "cleaning" kt) + (clean-value db table entity-id (list (ktv-key kt) (ktv-type kt)))) + (get-attribute-ids/types db table entity-type)))))) + +;; update an entity, via a (possibly partial) list of key/value pairs +;; if dirty is not true, this is coming from a sync +(define (update-entity-values db table entity-id ktvlist dirty) + (let* ((entity-type (get-entity-type db table entity-id))) + (cond + ((null? entity-type) (msg "entity" entity-id "not found!") '()) + (else + ;; update main entity type + (for-each + (lambda (ktv) + (when (not (equal? (ktv-key ktv) "unique_id")) + (find/add-attribute-type db table entity-type (ktv-key ktv) (ktv-type ktv)))) + ktvlist) + (for-each + (lambda (ktv) + (if dirty + (update-value db table entity-id ktv) + (update-value-from-sync db table entity-id ktv))) + ktvlist))))) + +;; update or create an entire entity if it doesn't exist +;; will return the new entity id if it's created +(define (update/insert-entity db table entity-type user entity-id ktvlist) + (let* ((entity-type (get-entity-type db table entity-id))) + (cond + ((null? entity-type) + (insert-entity db table entity-type user ktvlist)) + (else + (update-entity db table entity-id ktvlist) + #f)))) + +(define (insert-entity-if-not-exists db table entity-type user entity-id ktvlist) + (let ((found (get-entity-type db table entity-id))) + (if (null? found) + (insert-entity db table entity-type user ktvlist) + #f))) + + +(define (entity-update-test db table) + + (define e (insert-entity db table "thing" "me" (list (ktv "param1" "varchar" "bob") + (ktv "param2" "int" 30) + (ktv "param3" "real" 3.141) + (ktv "name" "varchar" "name") + (ktv "deleted" "int" 0)))) + + (asserteq "eav ent type" (get-entity-type db table e) "thing") + + (let ((e (get-entity db table e))) + (asserteq "entity get 1" (ktv-get e "param1") "bob") + (asserteq "entity get 2" (ktv-get e "param2") 30) + (assert "entity get 3" (feq (ktv-get e "param3") 3.141))) + + (update-value db table e (ktv "param1" "varchar" "fred")) + + (let ((e (get-entity db table e))) + (asserteq "update value 1" (ktv-get e "param1") "fred") + (asserteq "update value 2" (ktv-get e "param2") 30)) + + (assert "all-entities" (> (length (all-entities db table "thing")) 0)) + + (msg "hello") + + (update-entity db table e (list (ktv "param1" "varchar" "wotzit") + (ktv "param2" "int" 1))) + + (let ((e (get-entity db table e))) + (asserteq "update-entity 1" (ktv-get e "param1") "wotzit") + (asserteq "update-entity 2" (ktv-get e "param2") 1)) + + (update-entity db table e (list (ktv "param3" "real" 3.3))) + + (let ((e (get-entity db table e))) + (msg e) + (asserteq "update-entity 3" (ktv-get e "param1") "wotzit") + (asserteq "update-entity 4" (ktv-get e "param2") 1) + (assert "update-entity 5" (feq (ktv-get e "param3") 3.3))) + + (define e2 (insert-entity db table "thing" "me" + (list (ktv "param1" "varchar" "bob") + (ktv "param2" "int" 30) + (ktv "param3" "real" 3.141) + (ktv "param4" "int" 0)))) + + (let ((e (get-entity db table e2))) + (msg e) + (asserteq "new entity 1" (ktv-get e "param1") "bob") + (asserteq "new entity 2" (ktv-get e "param2") 30) + (assert "new entity 3" (feq (ktv-get e "param3") 3.141)) + (asserteq "new entity 3" (ktv-get e "param4") 0)) + + ) diff --git a/symbaidb/assets/eavdb_/entity-values.ss b/symbaidb/assets/eavdb_/entity-values.ss new file mode 100644 index 0000000000000000000000000000000000000000..8e0ef7044ffa51d6d6670bbb54b11984a79935ea --- /dev/null +++ b/symbaidb/assets/eavdb_/entity-values.ss @@ -0,0 +1,123 @@ +#lang racket + +;; Starwisp Copyright (C) 2014 Dave Griffiths +;; +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU Affero General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU Affero General Public License for more details. +;; +;; You should have received a copy of the GNU Affero General Public License +;; along with this program. If not, see . + +(require + "../web/scripts/utils.ss" + "../web/scripts/sql.ss" + "ktv.ss" + "ktv-list.ss") + +(provide (all-defined-out)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; putting data in + +;; get the type from the attribute table with an entity/key +(define (get-attribute-type db table entity-type key) + (let ((sql (string-append + "select attribute_type from " table + "_attribute where entity_type = ? and attribute_id = ?"))) + (select-first db sql entity-type key))) + +;; search for a type and add it if it doesn't exist +(define (find/add-attribute-type db table entity-type key type) + (let ((t (get-attribute-type db table entity-type key))) + ;; add and return passed in type if not exist + (cond + ((null? t) + (msg "adding new attribute for" entity-type " called " key " of type " type) + (db-insert + db (string-append "insert into " table "_attribute values (null, ?, ?, ?)") + key entity-type type) + type) + (else + (cond + ((equal? type t) t) + (else + (msg "type has changed for" entity-type key "from" t "to" type "???") + ;; wont work + ;; what do we do? + ;; some kind of coercion for existing data??? + type)))))) + +;; low level insert of a ktv +(define (insert-value db table entity-id ktv dirty) + ;; use type to dispatch insert to correct value table + (db-insert db (string-append "insert into " table "_value_" (ktv-type ktv) + " values (null, ?, ?, ?, ?, 0)") + entity-id (ktv-key ktv) (ktv-value ktv) (if dirty 1 0))) + +;; update the value given an entity type, a attribute type and it's key (= attriute_id) +;; creates the value if it doesn't already exist, updates it otherwise if it's different +(define (update-value db table entity-id ktv) + (let ((s (select-first + db (string-append + "select value from " table "_value_" (ktv-type ktv) " where entity_id = ? and attribute_id = ?") + entity-id (ktv-key ktv)))) + (if (null? s) + (insert-value db table entity-id ktv #t) + ;; only update if the are different + (if (not (ktv-eq? ktv (list (ktv-key ktv) (ktv-type ktv) s))) + (db-exec + db (string-append "update " table "_value_" (ktv-type ktv) + " set value=?, dirty=1 where entity_id = ? and attribute_id = ?") + (ktv-value ktv) entity-id (ktv-key ktv)) + '())))) ;;(msg "values for" (ktv-key ktv) "are the same (" (ktv-value ktv) "==" s ")"))))) + +;; don't make dirty or update version here +(define (update-value-from-sync db table entity-id ktv) + (let ((s (select-first + db (string-append + "select value from " table "_value_" (ktv-type ktv) " where entity_id = ? and attribute_id = ?") + entity-id (ktv-key ktv)))) + ;;(msg "update-value-from-sync" s) + ;;(msg ktv) + ;;(msg entity-id) + (if (null? s) + (insert-value db table entity-id ktv #t) + (db-exec + db (string-append "update " table "_value_" (ktv-type ktv) + " set value=?, dirty=0 where entity_id = ? and attribute_id = ?") + (ktv-value ktv) entity-id (ktv-key ktv))))) + +;; get all the (current) attributes for an entity type +(define (get-attribute-ids/types db table entity-type) + (let ((s (db-select + db (string-append + "select * from " table "_attribute where entity_type = ?") + entity-type))) + (if (null? s) '() + (map + (lambda (row) + (list (vector-ref row 1) ;; id + (vector-ref row 3))) ;; type + (cdr s))))) + +;; get the value, dirty and version given an entity type, a attribute type and it's key (= attriute_id) +(define (get-value db table entity-id kt) + (let ((s (db-select + db (string-append "select value, dirty from " table "_value_" (ktv-type kt) + " where entity_id = ? and attribute_id = ?") + entity-id (ktv-key kt)))) + (if (null? s) '() + (list (vector-ref (cadr s) 0) + (vector-ref (cadr s) 1))))) + +(define (clean-value db table entity-id kt) + (db-exec db (string-append "update " table "_value_" (ktv-type kt) + " set dirty=0 where entity_id = ? and attribute_id = ?") + entity-id (ktv-key kt))) diff --git a/symbaidb/assets/eavdb_/ktv-list.ss b/symbaidb/assets/eavdb_/ktv-list.ss new file mode 100644 index 0000000000000000000000000000000000000000..23ccf1e318be3e61ed477587b18cb2795f7bc9f7 --- /dev/null +++ b/symbaidb/assets/eavdb_/ktv-list.ss @@ -0,0 +1,40 @@ +;; Naked on Pluto Copyright (C) 2010 Aymeric Mansoux, Marloes de Valk, Dave Griffiths +;; +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU Affero General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU Affero General Public License for more details. +;; +;; You should have received a copy of the GNU Affero General Public License +;; along with this program. If not, see . + +#lang scheme +(require "ktv.ss") + +(provide (all-defined-out)) + +(define (ktv-get ktv-list key) + (cond + ((null? ktv-list) #f) + ((equal? (ktv-key (car ktv-list)) key) + (ktv-value (car ktv-list))) + (else (ktv-get (cdr ktv-list) key)))) + +(define (ktv-get-type ktv-list key) + (cond + ((null? ktv-list) #f) + ((equal? (ktv-key (car ktv-list)) key) + (ktv-type (car ktv-list))) + (else (ktv-get-type (cdr ktv-list) key)))) + +(define (ktv-set ktv-list ktv) + (cond + ((null? ktv-list) (list ktv)) + ((equal? (ktv-key (car ktv-list)) (ktv-key ktv)) + (cons ktv (cdr ktv-list))) + (else (cons (car ktv-list) (ktv-set (cdr ktv-list) ktv))))) diff --git a/symbaidb/assets/eavdb_/ktv.ss b/symbaidb/assets/eavdb_/ktv.ss new file mode 100644 index 0000000000000000000000000000000000000000..d70a3b68888d0e1e6d61c2bfb78a8af303209756 --- /dev/null +++ b/symbaidb/assets/eavdb_/ktv.ss @@ -0,0 +1,66 @@ +#lang scheme +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; basic key/type/value structure +;; used for all data internally, and maps to the eavdb types + +(require "../web/scripts/utils.ss") +(provide (all-defined-out)) + +(define (ktv key type value) (list key type value)) +(define ktv-key car) +(define ktv-type cadr) +(define ktv-value caddr) + +(define (ktv-eq? a b) + (and + (equal? (ktv-key a) (ktv-key b)) + (equal? (ktv-type a) (ktv-type b)) + (cond + ((or + (equal? (ktv-type a) "int") + (equal? (ktv-type a) "real")) + (eqv? (ktv-value a) (ktv-value b))) + ((or + (equal? (ktv-type a) "varchar") + (equal? (ktv-type a) "file")) + (equal? (ktv-value a) (ktv-value b))) + (else + (msg "unsupported ktv type in ktv-eq?: " (ktv-type a)) + #f)))) + +;; this is just used for the csv building +(define (null-value-for-type type) + (cond + ((equal? type "varchar") "not set") + ((equal? type "int") 0) + ((equal? type "real") 0) + ((equal? type "file") "not set"))) + +;; stringify based on type (for url) +(define (stringify-value ktv) + (cond + ((null? (ktv-value ktv)) "NULL") + ((equal? (ktv-type ktv) "varchar") (string-append "'" (ktv-value ktv) "'")) + (else + (if (not (string? (ktv-value ktv))) + (number->string (ktv-value ktv)) + (ktv-value ktv))))) + +;; stringify based on type (for url) +(define (stringify-value-url ktv) + (cond + ((null? (ktv-value ktv)) "NULL") + ((equal? (ktv-type ktv) "varchar") (ktv-value ktv)) + (else + (if (not (string? (ktv-value ktv))) + (number->string (ktv-value ktv)) + (ktv-value ktv))))) + +;; tests... + +(define (ktv-test) + (asserteq "ktv one" (stringify-value (ktv "one" "varchar" "two")) "'two'") + (asserteq "ktv 2" (stringify-value (ktv "one" "int" 3)) "3") + (asserteq "ktv 3" (stringify-value-url (ktv "one" "varchar" "two")) "two") + (asserteq "ktv 4" (stringify-value-url (ktv "one" "int" 3)) "3")) diff --git a/symbaidb/assets/fonts/DejaVuSans.ttf b/symbaidb/assets/fonts/DejaVuSans.ttf new file mode 100644 index 0000000000000000000000000000000000000000..19ed0b468804583c663869657c8706a38d0a9210 Binary files /dev/null and b/symbaidb/assets/fonts/DejaVuSans.ttf differ diff --git a/symbaidb/assets/fonts/DejaVuSerif.ttf b/symbaidb/assets/fonts/DejaVuSerif.ttf new file mode 100644 index 0000000000000000000000000000000000000000..0dfeb88230a8901a86564ed6418095f6eaa54013 Binary files /dev/null and b/symbaidb/assets/fonts/DejaVuSerif.ttf differ diff --git a/symbaidb/assets/fonts/Ginger-Light.otf b/symbaidb/assets/fonts/Ginger-Light.otf new file mode 100755 index 0000000000000000000000000000000000000000..75d9d16382cc0722505d22d4e438e436da6a7da1 Binary files /dev/null and b/symbaidb/assets/fonts/Ginger-Light.otf differ diff --git a/symbaidb/assets/fonts/Ginger-Regular.otf b/symbaidb/assets/fonts/Ginger-Regular.otf new file mode 100755 index 0000000000000000000000000000000000000000..27d66b2e045df99fab0e02f5e671f6f946517376 Binary files /dev/null and b/symbaidb/assets/fonts/Ginger-Regular.otf differ diff --git a/symbaidb/assets/fonts/Pfennig.ttf b/symbaidb/assets/fonts/Pfennig.ttf new file mode 100644 index 0000000000000000000000000000000000000000..bbbe4636d3ae6e45b9964c2dd87cadd2a646a78b Binary files /dev/null and b/symbaidb/assets/fonts/Pfennig.ttf differ diff --git a/symbaidb/assets/fonts/RobotoCondensed-Regular.ttf b/symbaidb/assets/fonts/RobotoCondensed-Regular.ttf new file mode 100644 index 0000000000000000000000000000000000000000..65bf32a19f9fe3d42d7f48f3f35c56b62b83513a Binary files /dev/null and b/symbaidb/assets/fonts/RobotoCondensed-Regular.ttf differ diff --git a/symbaidb/assets/fonts/grobold.ttf b/symbaidb/assets/fonts/grobold.ttf new file mode 100644 index 0000000000000000000000000000000000000000..4340bded9db8acadced93738827340d52725d5dc Binary files /dev/null and b/symbaidb/assets/fonts/grobold.ttf differ diff --git a/symbaidb/assets/fonts/grstylus.ttf b/symbaidb/assets/fonts/grstylus.ttf new file mode 100644 index 0000000000000000000000000000000000000000..525fbdfbed0378a8ebd0e5ca472ba0f5414b4c14 Binary files /dev/null and b/symbaidb/assets/fonts/grstylus.ttf differ diff --git a/symbaidb/assets/fonts/starwisp.ttf b/symbaidb/assets/fonts/starwisp.ttf new file mode 100644 index 0000000000000000000000000000000000000000..17a837b85f79c5c58385c4b5386922b3fccba92e Binary files /dev/null and b/symbaidb/assets/fonts/starwisp.ttf differ diff --git a/symbaidb/assets/init.scm b/symbaidb/assets/init.scm new file mode 100644 index 0000000000000000000000000000000000000000..5fe92a0481023dfa3d2e64a0556dda3bbb852e5d --- /dev/null +++ b/symbaidb/assets/init.scm @@ -0,0 +1,700 @@ +; Initialization file for TinySCHEME 1.39 + +; Per R5RS, up to four deep compositions should be defined +(define (caar x) (car (car x))) +(define (cadr x) (car (cdr x))) +(define (cdar x) (cdr (car x))) +(define (cddr x) (cdr (cdr x))) +(define (caaar x) (car (car (car x)))) +(define (caadr x) (car (car (cdr x)))) +(define (cadar x) (car (cdr (car x)))) +(define (caddr x) (car (cdr (cdr x)))) +(define (cdaar x) (cdr (car (car x)))) +(define (cdadr x) (cdr (car (cdr x)))) +(define (cddar x) (cdr (cdr (car x)))) +(define (cdddr x) (cdr (cdr (cdr x)))) +(define (caaaar x) (car (car (car (car x))))) +(define (caaadr x) (car (car (car (cdr x))))) +(define (caadar x) (car (car (cdr (car x))))) +(define (caaddr x) (car (car (cdr (cdr x))))) +(define (cadaar x) (car (cdr (car (car x))))) +(define (cadadr x) (car (cdr (car (cdr x))))) +(define (caddar x) (car (cdr (cdr (car x))))) +(define (cadddr x) (car (cdr (cdr (cdr x))))) +(define (cdaaar x) (cdr (car (car (car x))))) +(define (cdaadr x) (cdr (car (car (cdr x))))) +(define (cdadar x) (cdr (car (cdr (car x))))) +(define (cdaddr x) (cdr (car (cdr (cdr x))))) +(define (cddaar x) (cdr (cdr (car (car x))))) +(define (cddadr x) (cdr (cdr (car (cdr x))))) +(define (cdddar x) (cdr (cdr (cdr (car x))))) +(define (cddddr x) (cdr (cdr (cdr (cdr x))))) + +;;;; Utility to ease macro creation +(define (macro-expand form) + ((eval (get-closure-code (eval (car form)))) form)) + +(define (macro-expand-all form) + (if (macro? form) + (macro-expand-all (macro-expand form)) + form)) + +(define *compile-hook* macro-expand-all) + + +(macro (unless form) + `(if (not ,(cadr form)) (begin ,@(cddr form)))) + +(macro (when form) + `(if ,(cadr form) (begin ,@(cddr form)))) + +; DEFINE-MACRO Contributed by Andy Gaynor +(macro (define-macro dform) + (if (symbol? (cadr dform)) + `(macro ,@(cdr dform)) + (let ((form (gensym))) + `(macro (,(caadr dform) ,form) + (apply (lambda ,(cdadr dform) ,@(cddr dform)) (cdr ,form)))))) + +; Utilities for math. Notice that inexact->exact is primitive, +; but exact->inexact is not. +(define exact? integer?) +(define (inexact? x) (and (real? x) (not (integer? x)))) +(define (even? n) (= (remainder n 2) 0)) +(define (odd? n) (not (= (remainder n 2) 0))) +(define (zero? n) (= n 0)) +(define (positive? n) (> n 0)) +(define (negative? n) (< n 0)) +(define complex? number?) +(define rational? real?) +(define (abs n) (if (>= n 0) n (- n))) +(define (exact->inexact n) (* n 1.0)) +(define (<> n1 n2) (not (= n1 n2))) +(define (max . lst) + (foldr (lambda (a b) (if (> a b) a b)) (car lst) (cdr lst))) +(define (min . lst) + (foldr (lambda (a b) (if (< a b) a b)) (car lst) (cdr lst))) +(define (succ x) (+ x 1)) +(define (pred x) (- x 1)) +(define gcd + (lambda a + (if (null? a) + 0 + (let ((aa (abs (car a))) + (bb (abs (cadr a)))) + (if (= bb 0) + aa + (gcd bb (remainder aa bb))))))) +(define lcm + (lambda a + (if (null? a) + 1 + (let ((aa (abs (car a))) + (bb (abs (cadr a)))) + (if (or (= aa 0) (= bb 0)) + 0 + (abs (* (quotient aa (gcd aa bb)) bb))))))) + + +(define (string . charlist) + (list->string charlist)) + +(define (list->string charlist) + (let* ((len (length charlist)) + (newstr (make-string len)) + (fill-string! + (lambda (str i len charlist) + (if (= i len) + str + (begin (string-set! str i (car charlist)) + (fill-string! str (+ i 1) len (cdr charlist))))))) + (fill-string! newstr 0 len charlist))) + +(define (string-fill! s e) + (let ((n (string-length s))) + (let loop ((i 0)) + (if (= i n) + s + (begin (string-set! s i e) (loop (succ i))))))) + +(define (string->list s) + (let loop ((n (pred (string-length s))) (l '())) + (if (= n -1) + l + (loop (pred n) (cons (string-ref s n) l))))) + +(define (string-copy str) + (string-append str)) + +(define (string->anyatom str pred) + (let* ((a (string->atom str))) + (if (pred a) a + (error "string->xxx: not a xxx" a)))) + +(define (string->number str) (string->anyatom str number?)) + +(define (anyatom->string n pred) + (if (pred n) + (atom->string n) + (error "xxx->string: not a xxx" n))) + + +(define (number->string n) (anyatom->string n number?)) + +(define (char-cmp? cmp a b) + (cmp (char->integer a) (char->integer b))) +(define (char-ci-cmp? cmp a b) + (cmp (char->integer (char-downcase a)) (char->integer (char-downcase b)))) + +(define (char=? a b) (char-cmp? = a b)) +(define (char? a b) (char-cmp? > a b)) +(define (char<=? a b) (char-cmp? <= a b)) +(define (char>=? a b) (char-cmp? >= a b)) + +(define (char-ci=? a b) (char-ci-cmp? = a b)) +(define (char-ci? a b) (char-ci-cmp? > a b)) +(define (char-ci<=? a b) (char-ci-cmp? <= a b)) +(define (char-ci>=? a b) (char-ci-cmp? >= a b)) + +; Note the trick of returning (cmp x y) +(define (string-cmp? chcmp cmp a b) + (let ((na (string-length a)) (nb (string-length b))) + (let loop ((i 0)) + (cond + ((= i na) + (if (= i nb) (cmp 0 0) (cmp 0 1))) + ((= i nb) + (cmp 1 0)) + ((chcmp = (string-ref a i) (string-ref b i)) + (loop (succ i))) + (else + (chcmp cmp (string-ref a i) (string-ref b i))))))) + + +(define (string=? a b) (string-cmp? char-cmp? = a b)) +(define (string? a b) (string-cmp? char-cmp? > a b)) +(define (string<=? a b) (string-cmp? char-cmp? <= a b)) +(define (string>=? a b) (string-cmp? char-cmp? >= a b)) + +(define (string-ci=? a b) (string-cmp? char-ci-cmp? = a b)) +(define (string-ci? a b) (string-cmp? char-ci-cmp? > a b)) +(define (string-ci<=? a b) (string-cmp? char-ci-cmp? <= a b)) +(define (string-ci>=? a b) (string-cmp? char-ci-cmp? >= a b)) + +(define (list . x) x) + +(define (foldr f x lst) + (if (null? lst) + x + (foldr f (f x (car lst)) (cdr lst)))) + +(define (unzip1-with-cdr . lists) + (unzip1-with-cdr-iterative lists '() '())) + +(define (unzip1-with-cdr-iterative lists cars cdrs) + (if (null? lists) + (cons cars cdrs) + (let ((car1 (caar lists)) + (cdr1 (cdar lists))) + (unzip1-with-cdr-iterative + (cdr lists) + (append cars (list car1)) + (append cdrs (list cdr1)))))) + +(define (map proc . lists) + (if (null? lists) + (apply proc) + (if (null? (car lists)) + '() + (let* ((unz (apply unzip1-with-cdr lists)) + (cars (car unz)) + (cdrs (cdr unz))) + (cons (apply proc cars) (apply map (cons proc cdrs))))))) + +(define (for-each proc . lists) + (if (null? lists) + (apply proc) + (if (null? (car lists)) + #t + (let* ((unz (apply unzip1-with-cdr lists)) + (cars (car unz)) + (cdrs (cdr unz))) + (apply proc cars) (apply map (cons proc cdrs)))))) + +(define (list-tail x k) + (if (zero? k) + x + (list-tail (cdr x) (- k 1)))) + +(define (list-ref x k) + (car (list-tail x k))) + +(define (last-pair x) + (if (pair? (cdr x)) + (last-pair (cdr x)) + x)) + +(define (head stream) (car stream)) + +(define (tail stream) (force (cdr stream))) + +(define (vector-equal? x y) + (and (vector? x) (vector? y) (= (vector-length x) (vector-length y)) + (let ((n (vector-length x))) + (let loop ((i 0)) + (if (= i n) + #t + (and (equal? (vector-ref x i) (vector-ref y i)) + (loop (succ i)))))))) + +(define (list->vector x) + (apply vector x)) + +(define (vector-fill! v e) + (let ((n (vector-length v))) + (let loop ((i 0)) + (if (= i n) + v + (begin (vector-set! v i e) (loop (succ i))))))) + +(define (vector->list v) + (let loop ((n (pred (vector-length v))) (l '())) + (if (= n -1) + l + (loop (pred n) (cons (vector-ref v n) l))))) + +;; The following quasiquote macro is due to Eric S. Tiedemann. +;; Copyright 1988 by Eric S. Tiedemann; all rights reserved. +;; +;; Subsequently modified to handle vectors: D. Souflis + +(macro + quasiquote + (lambda (l) + (define (mcons f l r) + (if (and (pair? r) + (eq? (car r) 'quote) + (eq? (car (cdr r)) (cdr f)) + (pair? l) + (eq? (car l) 'quote) + (eq? (car (cdr l)) (car f))) + (if (or (procedure? f) (number? f) (string? f)) + f + (list 'quote f)) + (if (eqv? l vector) + (apply l (eval r)) + (list 'cons l r) + ))) + (define (mappend f l r) + (if (or (null? (cdr f)) + (and (pair? r) + (eq? (car r) 'quote) + (eq? (car (cdr r)) '()))) + l + (list 'append l r))) + (define (foo level form) + (cond ((not (pair? form)) + (if (or (procedure? form) (number? form) (string? form)) + form + (list 'quote form)) + ) + ((eq? 'quasiquote (car form)) + (mcons form ''quasiquote (foo (+ level 1) (cdr form)))) + (#t (if (zero? level) + (cond ((eq? (car form) 'unquote) (car (cdr form))) + ((eq? (car form) 'unquote-splicing) + (error "Unquote-splicing wasn't in a list:" + form)) + ((and (pair? (car form)) + (eq? (car (car form)) 'unquote-splicing)) + (mappend form (car (cdr (car form))) + (foo level (cdr form)))) + (#t (mcons form (foo level (car form)) + (foo level (cdr form))))) + (cond ((eq? (car form) 'unquote) + (mcons form ''unquote (foo (- level 1) + (cdr form)))) + ((eq? (car form) 'unquote-splicing) + (mcons form ''unquote-splicing + (foo (- level 1) (cdr form)))) + (#t (mcons form (foo level (car form)) + (foo level (cdr form))))))))) + (foo 0 (car (cdr l))))) + +;;;;;Helper for the dynamic-wind definition. By Tom Breton (Tehom) +(define (shared-tail x y) + (let ( (len-x (length x)) + (len-y (length y))) + (define (shared-tail-helper x y) + (if + (eq? x y) + x + (shared-tail-helper (cdr x) (cdr y)))) + (cond + ((> len-x len-y) + (shared-tail-helper + (list-tail x (- len-x len-y)) + y)) + ((< len-x len-y) + (shared-tail-helper + x + (list-tail y (- len-y len-x)))) + (#t (shared-tail-helper x y))))) + +;;;;;Dynamic-wind by Tom Breton (Tehom) + +;;Guarded because we must only eval this once, because doing so +;;redefines call/cc in terms of old call/cc +(unless (defined? 'dynamic-wind) + (let + ;;These functions are defined in the context of a private list of + ;;pairs of before/after procs. + ( (*active-windings* '()) + ;;We'll define some functions into the larger environment, so + ;;we need to know it. + (outer-env (current-environment))) + + ;;Poor-man's structure operations + (define before-func car) + (define after-func cdr) + (define make-winding cons) + + ;;Manage active windings + (define (activate-winding! new) + ((before-func new)) + (set! *active-windings* (cons new *active-windings*))) + (define (deactivate-top-winding!) + (let ((old-top (car *active-windings*))) + ;;Remove it from the list first so it's not active during its + ;;own exit. + (set! *active-windings* (cdr *active-windings*)) + ((after-func old-top)))) + + (define (set-active-windings! new-ws) + (unless (eq? new-ws *active-windings*) + (let ((shared (shared-tail new-ws *active-windings*))) + + ;;Define the looping functions. + ;;Exit the old list. Do deeper ones last. Don't do + ;;any shared ones. + (define (pop-many) + (unless (eq? *active-windings* shared) + (deactivate-top-winding!) + (pop-many))) + ;;Enter the new list. Do deeper ones first so that the + ;;deeper windings will already be active. Don't do any + ;;shared ones. + (define (push-many new-ws) + (unless (eq? new-ws shared) + (push-many (cdr new-ws)) + (activate-winding! (car new-ws)))) + + ;;Do it. + (pop-many) + (push-many new-ws)))) + + ;;The definitions themselves. + (eval + `(define call-with-current-continuation + ;;It internally uses the built-in call/cc, so capture it. + ,(let ((old-c/cc call-with-current-continuation)) + (lambda (func) + ;;Use old call/cc to get the continuation. + (old-c/cc + (lambda (continuation) + ;;Call func with not the continuation itself + ;;but a procedure that adjusts the active + ;;windings to what they were when we made + ;;this, and only then calls the + ;;continuation. + (func + (let ((current-ws *active-windings*)) + (lambda (x) + (set-active-windings! current-ws) + (continuation x))))))))) + outer-env) + ;;We can't just say "define (dynamic-wind before thunk after)" + ;;because the lambda it's defined to lives in this environment, + ;;not in the global environment. + (eval + `(define dynamic-wind + ,(lambda (before thunk after) + ;;Make a new winding + (activate-winding! (make-winding before after)) + (let ((result (thunk))) + ;;Get rid of the new winding. + (deactivate-top-winding!) + ;;The return value is that of thunk. + result))) + outer-env))) + +(define call/cc call-with-current-continuation) + + +;;;;; atom? and equal? written by a.k + +;;;; atom? +(define (atom? x) + (not (pair? x))) + +;;;; equal? +(define (equal? x y) + (cond + ((pair? x) + (and (pair? y) + (equal? (car x) (car y)) + (equal? (cdr x) (cdr y)))) + ((vector? x) + (and (vector? y) (vector-equal? x y))) + ((string? x) + (and (string? y) (string=? x y))) + (else (eqv? x y)))) + +;;;; (do ((var init inc) ...) (endtest result ...) body ...) +;; +(macro do + (lambda (do-macro) + (apply (lambda (do vars endtest . body) + (let ((do-loop (gensym))) + `(letrec ((,do-loop + (lambda ,(map (lambda (x) + (if (pair? x) (car x) x)) + `,vars) + (if ,(car endtest) + (begin ,@(cdr endtest)) + (begin + ,@body + (,do-loop + ,@(map (lambda (x) + (cond + ((not (pair? x)) x) + ((< (length x) 3) (car x)) + (else (car (cdr (cdr x)))))) + `,vars))))))) + (,do-loop + ,@(map (lambda (x) + (if (and (pair? x) (cdr x)) + (car (cdr x)) + '())) + `,vars))))) + do-macro))) + +;;;; generic-member +(define (generic-member cmp obj lst) + (cond + ((null? lst) #f) + ((cmp obj (car lst)) lst) + (else (generic-member cmp obj (cdr lst))))) + +(define (memq obj lst) + (generic-member eq? obj lst)) +(define (memv obj lst) + (generic-member eqv? obj lst)) +(define (member obj lst) + (generic-member equal? obj lst)) + +;;;; generic-assoc +(define (generic-assoc cmp obj alst) + (cond + ((null? alst) #f) + ((cmp obj (caar alst)) (car alst)) + (else (generic-assoc cmp obj (cdr alst))))) + +(define (assq obj alst) + (generic-assoc eq? obj alst)) +(define (assv obj alst) + (generic-assoc eqv? obj alst)) +(define (assoc obj alst) + (generic-assoc equal? obj alst)) + +(define (acons x y z) (cons (cons x y) z)) + +;;;; Handy for imperative programs +;;;; Used as: (define-with-return (foo x y) .... (return z) ...) +(macro (define-with-return form) + `(define ,(cadr form) + (call/cc (lambda (return) ,@(cddr form))))) + +;;;; Simple exception handling +; +; Exceptions are caught as follows: +; +; (catch (do-something to-recover and-return meaningful-value) +; (if-something goes-wrong) +; (with-these calls)) +; +; "Catch" establishes a scope spanning multiple call-frames +; until another "catch" is encountered. +; +; Exceptions are thrown with: +; +; (throw "message") +; +; If used outside a (catch ...), reverts to (error "message) + +(define *handlers* (list)) + +(define (push-handler proc) + (set! *handlers* (cons proc *handlers*))) + +(define (pop-handler) + (let ((h (car *handlers*))) + (set! *handlers* (cdr *handlers*)) + h)) + +(define (more-handlers?) + (pair? *handlers*)) + +(define (throw . x) + (if (more-handlers?) + (apply (pop-handler)) + (apply error x))) + +(macro (catch form) + (let ((label (gensym))) + `(call/cc (lambda (exit) + (push-handler (lambda () (exit ,(cadr form)))) + (let ((,label (begin ,@(cddr form)))) + (pop-handler) + ,label))))) + +(define *error-hook* throw) + + +;;;;; Definition of MAKE-ENVIRONMENT, to be used with two-argument EVAL + +(macro (make-environment form) + `(apply (lambda () + ,@(cdr form) + (current-environment)))) + +(define-macro (eval-polymorphic x . envl) + (display envl) + (let* ((env (if (null? envl) (current-environment) (eval (car envl)))) + (xval (eval x env))) + (if (closure? xval) + (make-closure (get-closure-code xval) env) + xval))) + +; Redefine this if you install another package infrastructure +; Also redefine 'package' +(define *colon-hook* eval) + +;;;;; I/O + +(define (input-output-port? p) + (and (input-port? p) (output-port? p))) + +(define (close-port p) + (cond + ((input-output-port? p) (close-input-port (close-output-port p))) + ((input-port? p) (close-input-port p)) + ((output-port? p) (close-output-port p)) + (else (throw "Not a port" p)))) + +(define (call-with-input-file s p) + (let ((inport (open-input-file s))) + (if (eq? inport #f) + #f + (let ((res (p inport))) + (close-input-port inport) + res)))) + +(define (call-with-output-file s p) + (let ((outport (open-output-file s))) + (if (eq? outport #f) + #f + (let ((res (p outport))) + (close-output-port outport) + res)))) + +(define (with-input-from-file s p) + (let ((inport (open-input-file s))) + (if (eq? inport #f) + #f + (let ((prev-inport (current-input-port))) + (set-input-port inport) + (let ((res (p))) + (close-input-port inport) + (set-input-port prev-inport) + res))))) + +(define (with-output-to-file s p) + (let ((outport (open-output-file s))) + (if (eq? outport #f) + #f + (let ((prev-outport (current-output-port))) + (set-output-port outport) + (let ((res (p))) + (close-output-port outport) + (set-output-port prev-outport) + res))))) + +(define (with-input-output-from-to-files si so p) + (let ((inport (open-input-file si)) + (outport (open-input-file so))) + (if (not (and inport outport)) + (begin + (close-input-port inport) + (close-output-port outport) + #f) + (let ((prev-inport (current-input-port)) + (prev-outport (current-output-port))) + (set-input-port inport) + (set-output-port outport) + (let ((res (p))) + (close-input-port inport) + (close-output-port outport) + (set-input-port prev-inport) + (set-output-port prev-outport) + res))))) + +; Random number generator (maximum cycle) +(define *seed* 1) +(define (random-next) + (let* ((a 16807) (m 2147483647) (q (quotient m a)) (r (modulo m a))) + (set! *seed* + (- (* a (- *seed* + (* (quotient *seed* q) q))) + (* (quotient *seed* q) r))) + (if (< *seed* 0) (set! *seed* (+ *seed* m))) + *seed*)) +;; SRFI-0 +;; COND-EXPAND +;; Implemented as a macro +(define *features* '(srfi-0)) + +(define-macro (cond-expand . cond-action-list) + (cond-expand-runtime cond-action-list)) + +(define (cond-expand-runtime cond-action-list) + (if (null? cond-action-list) + #t + (if (cond-eval (caar cond-action-list)) + `(begin ,@(cdar cond-action-list)) + (cond-expand-runtime (cdr cond-action-list))))) + +(define (cond-eval-and cond-list) + (foldr (lambda (x y) (and (cond-eval x) (cond-eval y))) #t cond-list)) + +(define (cond-eval-or cond-list) + (foldr (lambda (x y) (or (cond-eval x) (cond-eval y))) #f cond-list)) + +(define (cond-eval condition) + (cond ((symbol? condition) + (if (member condition *features*) #t #f)) + ((eq? condition #t) #t) + ((eq? condition #f) #f) + (else (case (car condition) + ((and) (cond-eval-and (cdr condition))) + ((or) (cond-eval-or (cdr condition))) + ((not) (if (not (null? (cddr condition))) + (error "cond-expand : 'not' takes 1 argument") + (not (cond-eval (cadr condition))))) + (else (error "cond-expand : unknown operator" (car condition))))))) + +(gc-verbose #f) diff --git a/symbaidb/assets/json.scm b/symbaidb/assets/json.scm new file mode 100644 index 0000000000000000000000000000000000000000..00efefe0b357767c388ca4bae86ba9183bd4ceae --- /dev/null +++ b/symbaidb/assets/json.scm @@ -0,0 +1,41 @@ +; convert scheme values into equivilent json strings + +(define (scheme->json v) + (cond + ((number? v) (number->string v)) + ((symbol? v) (string-append "\"" (symbol->string v) "\"")) + ((string? v) (string-append "\"" v "\"")) + ((boolean? v) (if v "true" "false")) + ((list? v) + (cond + ((null? v) "null") + (else + ; if it quacks like an assoc list... + (if (and (not (null? v)) (not (list? (car v))) (pair? (car v))) + (assoc->json v) + (list->json v))))) + (else (printf "value->js, unsupported type for ~a~n" v) 0))) + +(define (list->json l) + (define (_ l s) + (cond + ((null? l) s) + (else + (_ (cdr l) + (string-append s + (if (not (string=? s "")) ", " "") + (scheme->json (car l))))))) + (string-append "[" (_ l "") "]")) + +; ((one . 1) (two . "three")) -> { "one": 1, "two": "three } + +(define (assoc->json l) + (define (_ l s) + (cond + ((null? l) s) + (else + (let ((token (scheme->json (car (car l)))) + (value (scheme->json (cdr (car l))))) + (_ (cdr l) (string-append s (if (not (string=? s "")) "," "") + "\n" token ": " value)))))) + (string-append "{" (_ l "") "\n" "}")) diff --git a/symbaidb/assets/lib.scm b/symbaidb/assets/lib.scm new file mode 100644 index 0000000000000000000000000000000000000000..49a24af1abbe8d2594e9cfd3913e6acd14d5165b --- /dev/null +++ b/symbaidb/assets/lib.scm @@ -0,0 +1,948 @@ +;; Starwisp Copyright (C) 2013 Dave Griffiths +;; +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU Affero General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU Affero General Public License for more details. +;; +;; You should have received a copy of the GNU Affero General Public License +;; along with this program. If not, see . + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; debugging and unit tests + +(define (msg . args) + (for-each + (lambda (i) (display i)(display " ")) + args) + (newline)) + +(define (dbg i) (msg i) i) + +(define (assert msg v) + (display (string-append "testing " msg))(newline) + (when (not v) + (error "unit " msg))) + +(define (asserteq msg a b) + (display (string-append "testing " msg))(newline) + (when (not (equal? a b)) + (error "unit " msg a b))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; list stuff + +(define (filter fn l) + (foldl + (lambda (i r) + (if (fn i) (append r (list i)) r)) + '() + l)) + +(define (sort lst fn) + (if (null? lst) + '() + (insert (car 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) + (cond + ((null? l) #f) + ((equal? n (car (car l))) (car l)) + (else (find n (cdr l))))) + +(define (findv n l) + (cond + ((null? l) #f) + ((eqv? n (car (car l))) (car 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) + (cond + ((null? l) (list i)) + ;; overwrite existing + ((equal? (car i) (caar l)) (cons i (cdr l))) + ((stringexact (floor (+ bot (/ (- top bot) 2))))) + (mid (list-ref l m)) + (v (car mid))) + (cond + ((equal? k v) mid) + ((eqv? top bot) #f) + ((stringexact (floor (+ bot (/ (- top bot) 2))))) + (mid (list-ref l m)) + (v (car mid))) + (cond + ((eqv? k v) mid) + ((eqv? top bot) #f) + ((< k v) (_ bot m)) + (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) + (cond ((zero? n) l) + (else + (_ fn (- n 1) (cons (fn (- n 1)) l))))) + (_ fn n '())) + +(define (foldl op initial seq) + (define (iter result rest) + (if (null? rest) + result + (iter (op (car rest) result) (cdr rest)))) + (iter initial seq)) + +(define (insert-to i p l) + (cond + ((null? l) (list i)) + ((zero? p) (cons i l)) + (else + (cons (car l) (insert-to i (- p 1) (cdr l)))))) + +;; (list-replace '(1 2 3 4) 2 100) => '(1 2 100 4) +(define (list-replace l i v) + (cond + ((null? l) l) + ((zero? i) (cons v (list-replace (cdr l) (- i 1) v))) + (else (cons (car l) (list-replace (cdr l) (- i 1) v))))) + +(define (insert elt fn sorted-lst) + (if (null? sorted-lst) + (list elt) + (if (fn elt (car sorted-lst)) + (cons elt sorted-lst) + (cons (car sorted-lst) + (insert elt fn (cdr sorted-lst)))))) + +(define (choose l) + (list-ref l (random (length l)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; time + +(define (time->seconds t) + (+ (car t) (/ (cadr t) 1000000))) + +(define start-time (time->seconds (time-of-day))) + +(define (time-now) + (- (time->seconds (time-of-day)) start-time)) + +;; just for graph so don't have to be accurate!!! +(define (date->day d) + (+ (* (list-ref d 2) 360) + (* (list-ref d 1) 30) + (list-ref d 0))) + +(define (date< a b) + (cond + ((< (list-ref a 2) (list-ref b 2)) #t) + ((> (list-ref a 2) (list-ref b 2)) #f) + (else ;; year is the same + (cond + ((< (list-ref a 1) (list-ref b 1)) #t) + ((> (list-ref a 1) (list-ref b 1)) #f) + (else ;; month is the same + (cond + ((< (list-ref a 0) (list-ref b 0)) #t) + ((> (list-ref a 0) (list-ref b 0)) #f) + (else #f))))))) + + +(define (date->string d) + (string-append + (number->string (list-ref d 0)) + "-" + (substring (number->string (+ (list-ref d 1) 100)) 1 3) + "-" + (substring (number->string (+ (list-ref d 2) 100)) 1 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; random + +(define random-maker + (let* ((multiplier 48271) + (modulus 2147483647) + (apply-congruence + (lambda (current-seed) + (let ((candidate (modulo (* current-seed multiplier) + modulus))) + (if (zero? candidate) + modulus + candidate)))) + (coerce + (lambda (proposed-seed) + (if (integer? proposed-seed) + (- modulus (modulo proposed-seed modulus)) + 19860617)))) ;; an arbitrarily chosen birthday + (lambda (initial-seed) + (let ((seed (coerce initial-seed))) + (lambda args + (cond ((null? args) + (set! seed (apply-congruence seed)) + (/ (- modulus seed) modulus)) + ((null? (cdr args)) + (let* ((proposed-top + (ceiling (abs (car args)))) + (exact-top + (if (inexact? proposed-top) + (inexact->exact proposed-top) + proposed-top)) + (top + (if (zero? exact-top) + 1 + exact-top))) + (set! seed (apply-congruence seed)) + (inexact->exact (floor (* top (/ seed modulus)))))) + ((eq? (cadr args) 'reset) + (set! seed (coerce (car args)))) + (else + (display "random: unrecognized message") + (newline)))))))) + +(define rand + (random-maker 19781116)) ;; another arbitrarily chosen birthday + +(define (random n) + (abs (modulo (rand n) n))) + +(define rndf rand) + +(define (rndvec) (vector (rndf) (rndf) (rndf))) + +(define (crndf) + (* (- (rndf) 0.5) 2)) + +(define (crndvec) + (vector (crndf) (crndf) (crndf))) + +(define (srndvec) + (let loop ((v (crndvec))) + (if (> (vmag v) 1) ; todo: use non sqrt version + (loop (crndvec)) + v))) + +(define (hsrndvec) + (let loop ((v (crndvec))) + (let ((l (vmag v))) + (if (or (> l 1) (eq? l 0)) + (loop (crndvec)) + (vdiv v l))))) + +(define (grndf) + (let loop ((x (crndf)) (y (crndf))) + (let ((l (+ (* x x) (* y y)))) + (if (or (>= l 1) (eq? l 0)) + (loop (crndf) (crndf)) + (* (sqrt (/ (* -2 (log l)) l)) x))))) + +(define (grndvec) + (vector (grndf) (grndf) (grndf))) + +(define (rndbary) + (let* + ((a (- 1.0 (sqrt (rndf)))) + (b (* (rndf) (- 1.0 a))) + (c (- 1.0 (+ a b)))) + (vector a b c))) + +; return a line on the hemisphere +(define (rndhemi n) + (let loop ((v (srndvec))) + (if (> (vdot n v) 0) + v + (loop (srndvec))))) + +(define (hrndhemi n) + (let loop ((v (hsrndvec))) + (if (> (vdot n v) 0) + 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 + +(define (scheme->json v) + (cond + ((number? v) (number->string v)) + ((symbol? v) (string-append "\"" (symbol->string v) "\"")) + ((string? v) (string-append "\"" v "\"")) + ((boolean? v) (if v "true" "false")) + ((list? v) + (cond + ((null? v) "[]") + (else + ; if it quacks like an assoc list... + (if (and (not (null? v)) (not (list? (car v))) (pair? (car v))) + (assoc->json v) + (list->json v))))) + (else "[]"))) ;;(display "value->js, unsupported type for ") (display v) (newline) "[]"))) + +(define (list->json l) + (define (_ l s) + (cond + ((null? l) s) + (else + (_ (cdr l) + (string-append + s + (if (not (string=? s "")) ", " "") + (scheme->json (car l))))))) + (string-append "[" (_ l "") "]")) + +; ((one . 1) (two . "three")) -> { "one": 1, "two": "three } + +(define (assoc->json l) + (define (_ l s) + (cond + ((null? l) s) + (else + (let ((token (scheme->json (car (car l)))) + (value (scheme->json (cdr (car l))))) + (_ (cdr l) (string-append s (if (not (string=? s "")) "," "") + "\n" token ": " value)))))) + (string-append "{" (_ l "") "\n" "}")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; android ui + +(define (layout width height weight gravity margin) (list "layout" width height weight gravity margin)) +(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)) + +;; all the widgets! +(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)) +(define (scroll-view id layout children) + (list "scroll-view" id layout children)) +(define (scroll-view-vert id layout children) + (list "scroll-view-vert" id layout children)) +(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) + (list "view-pager" id layout fragment-list)) +(define (space layout) (list "space" "999" layout)) +(define (space-view-layout t) (list-ref t 2)) +(define (image-view id image layout) (list "image-view" id image layout)) +(define (camera-preview id layout) (list "camera-preview" id layout)) +(define (text-view id text size layout) (list "text-view" id text size layout)) +(define (debug-text-view id text size layout) (list "debug-text-view" id text size layout)) +(define (web-view id data layout) (list "web-view" id data layout)) +(define (edit-text id text size type layout listener) (list "edit-text" id text size type layout listener)) +(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-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-listener t) (list-ref t 6)) +(define (seek-bar id max layout listener) (list "seek-bar" id max layout listener)) +(define (seek-bar-listener t) (list-ref t 4)) +(define (spinner id items layout listener) (list "spinner" id items layout listener)) +(define (spinner-listener t) (list-ref t 4)) +(define (canvas id layout drawlist) (list "canvas" id layout drawlist)) +(define (canvas-drawlist t) (list-ref t 3)) +(define (button-grid id type height textsize layout buttons listener) + (list "button-grid" id type height textsize layout buttons listener)) +(define (button-grid-listener b) (list-ref b 7)) +(define (drawlist-line colour width points) (list "line" colour width points)) +(define (drawlist-text text x y colour size align) (list "text" text x y colour size align)) + +(define (toast msg) (list "toast" 0 "toast" msg)) +(define (play-sound wav) (list "play-sound" 0 "play-sound" wav)) +(define (soundfile-start-recording wav) (list "soundfile-start-recording" 0 "soundfile-start-recording" wav)) +(define (soundfile-stop-recording) (list "soundfile-stop-recording" 0 "soundfile-stop-recording")) +(define (soundfile-start-playback wav) (list "soundfile-start-playback" 0 "soundfile-start-playback" wav)) +(define (soundfile-stop-playback) (list "soundfile-stop-playback" 0 "soundfile-stop-playback")) +(define (vibrate time) (list "vibrate" 0 "vibrate" time)) +(define (make-directory name) (list "make-directory" 0 "make-directory" name)) +;; treat this like a dialog so the callback fires +(define (list-files name path fn) (list "list-files" 0 "list-files" name fn path)) +(define (gps-start name fn) (list "gps-start" 0 "gps-start" name fn)) +(define (delayed name delay fn) (list "delayed" 0 "delayed" name fn delay)) +(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-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 (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) + (list "dialog-fragment" 0 "dialog-fragment" id layout fragment-name fn)) + +(define (time-picker-dialog name fn) + (list "time-picker-dialog" 0 "time-picker-dialog" name fn)) +(define (date-picker-dialog name fn) + (list "date-picker-dialog" 0 "date-picker-dialog" name fn)) +(define (alert-dialog name msg fn) + (list "alert-dialog" 0 "alert-dialog" name fn msg)) +(define (dialog-type d) (list-ref d 2)) +(define (dialog-name d) (list-ref d 3)) +(define (dialog-fn d) (list-ref d 4)) + +(define (start-activity act request arg) (list "start-activity" 0 "start-activity" act request arg)) +(define (start-activity-goto act request arg) (list "start-activity" 0 "start-activity-goto" act arg)) +(define (finish-activity result) (list "finish-activity" 0 "finish-activity" result)) + +(define (build-fragment type id layout) (list "build-fragment" type id layout)) +(define (replace-fragment id type) (list "replace-fragment" id type)) + +(define (update-widget type id token value) (list type id token value)) +(define (update-widget-type l) (list-ref l 0)) +(define (update-widget-id l) (list-ref l 1)) +(define (update-widget-token l) (list-ref l 2)) +(define (update-widget-value l) (list-ref l 3)) + +(define id-map ()) +(define current-id 1) + +;(define (find-id name id-map) +; (cond +; ((null? id-map) #f) +; ((equal? name (car (car id-map))) (cadr (car id-map))) +; (else (find-id name (cdr id-map))))) + +;(define (get-id name) +; (find-id name id-map)) + +;(define (make-id name) +; (let ((existing (get-id name))) +; (cond +; (existing existing) +; (else +; (set! id-map (cons (list name current-id) id-map)) +; (set! current-id (+ current-id 1)) +; (get-id name))))) + +;(define (get-id name) +; (cadr (sorted-find id-map name))) + +;(define (make-id name) +; (prof-start "make-id") +; (prof-start "make-id sorted find") +; (let ((sf (sorted-find id-map name))) +; (prof-end "make-id sorted find") +; (let ((r (if (not sf) +; (let ((id current-id)) +; (prof-start "make-id sorted add") +; (set! id-map (sorted-add id-map (list name id))) + ; (prof-end "make-id sorted add") +; (set! current-id (+ current-id 1)) +; id) +; (cadr sf)))) +; (prof-end "make-id") +; r))) + +(define (get-id name) + (let ((r (id-map-get name))) + (cond + ((zero? r) (msg "no id found for" name) 0) + (else r)))) + +(define (make-id name) + ;;(msg "making id for" name) + (let ((id (id-map-get name))) + (cond + ((zero? id) + ;;(msg "this is a new id") + ; (prof-start "make-id") + (id-map-add name current-id) + (set! current-id (+ current-id 1)) + ; (prof-end "make-id") + (- current-id 1)) + (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 (new-prof-item id) + (list id (time-now) 0 0)) +(define (prof-item-id p) (list-ref p 0)) +(define (prof-item-time p) (list-ref p 1)) +(define (prof-item-accum p) (list-ref p 2)) +(define (prof-item-calls p) (list-ref p 3)) + +(define (prof-item-restart p) + (list + (prof-item-id p) + (time-now) + (prof-item-accum p) + (prof-item-calls p))) + +(define (prof-item-end p) + (list + (prof-item-id p) + 0 + (+ (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 + prof-map (prof-item-restart dd))) + (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 + (prof-item-end d))))) + +(define (prof-print) + (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) + (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)) +(define fill (layout 'fill-parent 'fill-parent -1 'left 0)) + +(define (spacer size) (space (layout 'fill-parent size 1 'left 0))) + + +(define (horiz . l) + (linear-layout + 0 'horizontal + (layout 'fill-parent 'wrap-content -1 'centre 0) + (list 0 0 0 0) + l)) + +(define (horiz-colour col . l) + (linear-layout + 0 'horizontal + (layout 'fill-parent 'wrap-content -1 'centre 0) + col + l)) + +(define (vert . l) + (linear-layout + 0 'vertical + (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) + l)) + +(define (relative rules colour . l) + (relative-layout + 0 (rlayout 'fill-parent 'wrap-content (list 20 20 20 20) rules) + colour + 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)) + +(define (fragment name layout on-create on-start on-resume on-pause on-stop on-destroy) + (list name layout on-create on-start on-resume on-pause on-stop on-destroy)) + +(define (activity-name a) (list-ref a 0)) +(define (activity-layout a) (list-ref a 1)) +(define (activity-modify-layout a v) (list-replace a 1 v)) +(define (activity-on-create a) (list-ref a 2)) +(define (activity-on-start a) (list-ref a 3)) +(define (activity-on-resume a) (list-ref a 4)) +(define (activity-on-pause a) (list-ref a 5)) +(define (activity-on-stop a) (list-ref a 6)) +(define (activity-on-destroy a) (list-ref a 7)) +(define (activity-on-activity-result a) (list-ref a 8)) + +(define (activity-list l) l) + +(define (activity-list-find l name) + (cond + ((null? l) #f) + ((equal? (activity-name (car l)) name) (car l)) + (else (activity-list-find (cdr l) name)))) + +(define activities 0) +(define fragments 0) + +(define callbacks '()) +(define (callback id type fn) (list id type fn)) +(define (callback-id l) (list-ref l 0)) +(define (callback-type l) (list-ref l 1)) +(define (callback-fn l) (list-ref l 2)) +(define (find-callback id) (sorted-findv callbacks id)) +(define (add-callback! cb) + ;;(msg "adding" cb) + (set! callbacks (sorted-addv callbacks cb))) + +(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) "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)) + (else '()))) + +(define (widget-get-callback w) + (cond + ((equal? (widget-type w) "edit-text") (edit-text-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) "seek-bar") (seek-bar-listener w)) + ((equal? (widget-type w) "spinner") (spinner-listener w)) + ((equal? (widget-type w) "button-grid") (button-grid-listener w)) + ((equal? (widget-type w) "draggable") (draggable-listener w)) + (else #f))) + +;; walk through activity stripping callbacks +;; version called from on-create +(define (update-callbacks! widget-list) + (cond + ((null? widget-list) #f) + (else + (let* ((w (car widget-list)) + (c (widget-get-children w))) + (when (not (null? c)) + (update-callbacks! c)) + (let ((cb (widget-get-callback w))) + (when cb + (add-callback! (callback (widget-id w) (widget-type w) cb))))) + (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))) + (cond + ((null? w) #f) + ;; drill deeper + ((eq? (update-widget-token w) 'contents) + (update-callbacks! (update-widget-value w))) + ((eq? (update-widget-token w) 'contents-add) + (update-callbacks! (update-widget-value w))) + ((eq? (update-widget-token w) 'grid-buttons) + (add-callback! (callback (update-widget-id w) + "button-grid" + (list-ref (update-widget-value w) 5))))) + (update-callbacks-from-update! (cdr widget-list))))) + +(define (define-activity-list . args) + (set! activities (activity-list args))) + +(define (define-fragment-list . args) + (set! fragments (activity-list args))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; replace with new cb system + +(define dialogs '()) + +(define (dialog-find dl name) + (cond + ((null? dl) #f) + ((equal? (dialog-name (car dl)) name) (car dl)) + (else (dialog-find (cdr dl) name)))) + +(define (dialog-replace dl name d) + (cond + ((null? dl) (list d)) + ((equal? (dialog-name (car dl)) name) + (cons d (cdr dl))) + (else (cons (car dl) (dialog-replace (cdr dl) name d))))) + + +(define (add-new-dialog! d) + (set! dialogs (dialog-replace dialogs (dialog-name d) d)) + ;; todo - when to clear out? + ;;(when (not (dialog-find dialogs (dialog-name d))) + ;;(display "adding dialog ")(display d)(newline) + ;; (set! dialogs (cons d dialogs))) + ) + + +(define (update-dialogs! events) + (when (list? events) + (for-each + (lambda (event) + (when (or + ;; todo - something a bit more fancy + (equal? (list-ref event 0) "date-picker-dialog") + (equal? (list-ref event 0) "alert-dialog") + (equal? (list-ref event 0) "list-files") + (equal? (list-ref event 0) "http-request") + (equal? (list-ref event 0) "network-connect") + (equal? (list-ref event 0) "delayed") + (equal? (list-ref event 0) "walk-draggable") + (equal? (list-ref event 0) "gps-start")) + (add-new-dialog! event))) + events))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (dialog-callback name args) + (let ((dialog (dialog-find dialogs name))) + (if (not dialog) + (begin (display "no dialog called ")(display name)(newline)) + (let ((events (apply (dialog-fn dialog) args))) + (update-dialogs! events) + (update-callbacks-from-update! events) + (send (scheme->json events)))))) + +;; called by java +(define (activity-callback type activity-name args) + (prof-start "activity-callback") + (let ((r (let ((activity (activity-list-find activities activity-name))) + (top-callback type activity-name activity args)))) + (prof-end "activity-callback") + r)) + +;; called by java +(define (fragment-callback type fragment-name args) + (prof-start "activity-callback") + (let ((r (let ((fragment (activity-list-find fragments fragment-name))) + (top-callback type fragment-name fragment args)))) + (prof-end "activity-callback") + r)) + +(define (top-callback type activity-name activity args) + ;;(display "activity/fragment-callback ")(display type)(display " ")(display args)(newline) + (if (not activity) + (begin (display "no activity/fragment called ")(display activity-name)(newline)) + (let ((ret (cond + ;; todo update activity...? + ((eq? type 'on-create) ((activity-on-create activity) activity (car args))) + ((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)) + ((eq? type 'on-destroy) ((activity-on-destroy activity) activity)) + ((eq? type 'on-activity-result) ((activity-on-activity-result activity) activity (car args) (cadr args))) + (else + (display "no callback called ")(display type)(newline) + '())))) + (cond + ((eq? type 'on-create) + (update-callbacks! (list ret))) + (else + (update-dialogs! ret) + (update-callbacks-from-update! ret))) + (send (scheme->json ret))))) + +(define (find-activity-or-fragment name) + (let ((r (activity-list-find activities name))) + (if r r + (activity-list-find fragments name)))) + +(define (widget-callback activity-name widget-id args) + (prof-start "widget-callback") + (let ((cb (find-callback widget-id))) + (if (not cb) + (msg "no widget" widget-id "found!") + (let ((events + (cond + ((equal? (callback-type cb) "edit-text") + ((callback-fn cb) (car args))) + ((equal? (callback-type cb) "button") + ((callback-fn cb))) + ((equal? (callback-type cb) "image-button") + ((callback-fn cb))) + ((equal? (callback-type cb) "toggle-button") + ((callback-fn cb) (car args))) + ((equal? (callback-type cb) "seek-bar") + ((callback-fn cb) (car args))) + ((equal? (callback-type cb) "spinner") + ((callback-fn cb) (car args))) + ((equal? (callback-type cb) "button-grid") + ((callback-fn cb) (car args) (cadr args))) + ((equal? (callback-type cb) "draggable") + ((callback-fn cb))) + (else + (msg "no callbacks for type" (callback-type cb)))))) + ;; 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) + (send (scheme->json events)) + (prof-end "widget-callback"))))) + + +(alog "lib.scm done") diff --git a/symbaidb/assets/racket-fix.scm b/symbaidb/assets/racket-fix.scm new file mode 100644 index 0000000000000000000000000000000000000000..5859170a5a6f34b000f1489c3b07c0bf0ed00d6c --- /dev/null +++ b/symbaidb/assets/racket-fix.scm @@ -0,0 +1,28 @@ +(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))))) diff --git a/symbaidb/assets/starwisp.scm b/symbaidb/assets/starwisp.scm new file mode 100644 index 0000000000000000000000000000000000000000..654926443c9e32f1dd39cee782ca912af0c12540 --- /dev/null +++ b/symbaidb/assets/starwisp.scm @@ -0,0 +1,246 @@ +;; Starwisp Copyright (C) 2013 Dave Griffiths +;; +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU Affero General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU Affero General Public License for more details. +;; +;; You should have received a copy of the GNU Affero General Public License +;; along with this program. If not, see . + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; strings + + +;; colours +(msg "starting up....") +(define entity-types (list "village" "household" "individual" "child" "crop")) + +(define trans-col (list 0 0 0 0)) +(define colour-one (list 0 0 255 100)) +(define colour-two (list 127 127 255 100)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; persistent database + +(define db "/sdcard/symbai/local-symbai.db") +(db-open db) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; user interface abstraction + +(define (mbutton id title fn) + (button (make-id id) title 20 (layout 'fill-parent 'wrap-content 1 'centre 5) fn)) + +(define (mbutton2 id title fn) + (button (make-id id) title 20 (layout 150 100 1 'centre 5) fn)) + +(define (mbutton-small id title fn) + (button (make-id id) title 30 (layout 'wrap-content 'wrap-content -1 'right 5) fn)) + +(define (mtoggle-button id title fn) + (toggle-button (make-id id) title 20 (layout 'fill-parent 'wrap-content 1 'centre 5) "fancy" fn)) + +(define (mtoggle-button-yes id title fn) + (toggle-button (make-id id) title 20 (layout 49 43 1 'centre 0) "yes" fn)) + +(define (mtoggle-button-maybe id title fn) + (toggle-button (make-id id) title 20 (layout 49 43 1 'centre 0) "maybe" fn)) + +(define (mtoggle-button-no id title fn) + (toggle-button (make-id id) title 20 (layout 49 43 1 'centre 0) "no" fn)) + +(define (mtoggle-button2 id title fn) + (toggle-button (make-id id) title 20 (layout 150 100 1 'centre 5) "plain" fn)) + +(define (mspinner id list fn) + (spinner (make-id id) (map cadr list) fillwrap fn)) + +(define (mspinner-scale id list fn) + (spinner (make-id id) (map cadr list) (layout 'fill-parent 'wrap-content 1 'centre 0) fn)) + +(define (mtext id text) + (text-view (make-id id) text 20 (layout 'fill-parent 'wrap-content 1 'centre 0))) + +(define (mtitle id text) + (text-view (make-id id) text 40 (layout 'fill-parent 'wrap-content 1 'centre 0))) + +(define (medit-text id text type fn) + (vert + (mtext (string-append id "-title") text) + (edit-text (make-id id) "" 20 type (layout 'fill-parent 'wrap-content 1 'centre 0) fn))) + +(define (medit-text-value id text value type fn) + (linear-layout + 0 'horizontal + (layout 'fill-parent 'wrap-content -1 'centre 2) + (list 0 0 0 10) + (list + (text-view (make-id (string-append id "-title")) text 20 (layout 'fill-parent 'wrap-content 1 'right 0)) + (edit-text (make-id id) value 20 type (layout 'fill-parent 'wrap-content 1 'centre 0) fn)))) + +(define (mclear-toggles id-list) + (map + (lambda (id) + (update-widget 'toggle-button (get-id id) 'checked 0)) + id-list)) + +(define (mclear-toggles-not-me me id-list) + (foldl + (lambda (id r) + (if (equal? me id) + r (cons (update-widget 'toggle-button (get-id id) 'checked 0) r))) + '() id-list)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; review + +(define (review-build-contents uid entity) + (append + (foldl + (lambda (ktv r) + (append + r (cond + ((equal? (ktv-type ktv) "varchar") + ;; normal varchar + (list (medit-text-value (string-append uid (ktv-key ktv)) + (string-append (ktv-key ktv) " : " (ktv-type ktv)) + (ktv-value ktv) "normal" + (lambda (v) + (entity-set-value-mem! (ktv-key ktv) (ktv-type ktv) v) '())))) + ((equal? (ktv-type ktv) "file") + ;; normal varchar + (list (medit-text-value (string-append uid (ktv-key ktv)) + (string-append (ktv-key ktv) " : " (ktv-type ktv)) + (ktv-value ktv) "normal" + (lambda (v) + (entity-set-value-mem! (ktv-key ktv) (ktv-type ktv) v) '())))) + ((equal? (ktv-type ktv) "int") + (list (medit-text-value (string-append uid (ktv-key ktv)) + (string-append (ktv-key ktv) " : " (ktv-type ktv)) + (number->string (ktv-value ktv)) "numeric" + (lambda (v) + (entity-set-value-mem! (ktv-key ktv) (ktv-type ktv) v) '())))) + ((equal? (ktv-type ktv) "real") + (list (medit-text-value (string-append uid (ktv-key ktv)) + (string-append (ktv-key ktv) " : " (ktv-type ktv)) + ;; get around previous bug, should remove + (if (number? (ktv-value ktv)) + (number->string (ktv-value ktv)) + (ktv-value ktv)) "numeric" + (lambda (v) + (entity-set-value-mem! (ktv-key ktv) (ktv-type ktv) v) '())))) + (else (mtext "" (string-append (ktv-type ktv) " not handled!!")) '())))) + '() + entity) + (list + (horiz + (mbutton "review-item-cancel" "Cancel" (lambda () (list (finish-activity 0)))) + (mbutton (string-append uid "-save") "Save" + (lambda () + (list + (alert-dialog + "review-ok" + (string-append "Are you sure?") + (lambda (v) + (cond + ((eqv? v 1) + (entity-update-values!) + (list)) + (else (list)))))))))))) + + +(define (review-item-build) + (let ((uid (entity-get-value "unique_id"))) + (list + (update-widget + 'linear-layout + (get-id "review-item-container") + 'contents + (review-build-contents + uid (get-current 'entity-values '())))))) + +(define (review-update-list entity-type) + (list + (update-widget + 'linear-layout (get-id "review-list") 'contents + (map + (lambda (e) + (let* ((uid (ktv-get e "unique_id"))) + (msg e) + (mbutton + (string-append "review-" uid) + (ktv-get e "name") + (lambda () + (entity-init! db "sync" entity-type (get-entity-by-unique db "sync" uid)) + (list (start-activity "review-item" 0 "")))))) + (db-filter-only-inc-deleted db "sync" entity-type + (list) + (list (list "name" "varchar"))))))) + + +(define-activity-list + + (activity + "main" + (vert + (horiz + (text-view 0 "Symbai db admin" 40 (layout 'fill-parent 'wrap-content 1 'left 0)) + (mspinner-scale "entity-type" (map (lambda (v) (list "" v)) entity-types) + (lambda (v) + (review-update-list + (list-ref entity-types v))))) + + + (scroll-view-vert + 0 (layout 'fill-parent 'wrap-content 1 'left 0) + (list + (linear-layout + (make-id "review-list") + 'vertical + (layout 'fill-parent 'fill-parent 1 'left 0) + (list 0 0 0 0) + (list)) + ))) + (lambda (activity arg) + (activity-layout activity)) + (lambda (activity arg) '()) + (lambda (activity) '()) + (lambda (activity) '()) + (lambda (activity) '()) + (lambda (activity) '()) + (lambda (activity requestcode resultcode) '())) + + (activity + "review-item" + (vert + (text-view (make-id "title") "Edit item" 40 fillwrap) + (scroll-view-vert + 0 (layout 'fill-parent 'wrap-content 1 'left 0) + (list + (linear-layout + (make-id "review-item-container") + 'vertical + (layout 'fill-parent 'wrap-content 1 'left 0) + (list 0 0 0 0) + (list)))) + ) + (lambda (activity arg) + (activity-layout activity)) + (lambda (activity arg) + (review-item-build)) + (lambda (activity) '()) + (lambda (activity) '()) + (lambda (activity) '()) + (lambda (activity) '()) + (lambda (activity requestcode resultcode) '())) + + ) + + +;(build-test! db "sync" village-ktvlist household-ktvlist individual-ktvlist) diff --git a/symbaidb/assets/test.scm b/symbaidb/assets/test.scm new file mode 100644 index 0000000000000000000000000000000000000000..c59e1f238040462f1fb012065e4a39a81d032110 --- /dev/null +++ b/symbaidb/assets/test.scm @@ -0,0 +1,100 @@ +;; Starwisp Copyright (C) 2013 Dave Griffiths +;; +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU Affero General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU Affero General Public License for more details. +;; +;; You should have received a copy of the GNU Affero General Public License +;; along with this program. If not, see . + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-activity-list + (activity + "main" + (linear-layout + (make-id "top") + 'vertical + (layout 'fill-parent 'fill-parent 1 'left) + (list + (spinner (make-id "spinner") (list "one" "two" "three" "cows") fillwrap + (lambda (v) + (display "spinner fn called")(newline) + (list (update-widget 'text-view (get-id "view3") 'text v)))) + (edit-text (make-id "name") "Name" 20 fillwrap + (lambda (v) (list (update-widget 'text-view 999 'text v)))) + (linear-layout + (make-id "foo") + 'horizontal + (layout 'fill-parent 'fill-parent 1 'centre) + (list + (button (make-id "but1") "Click me" 20 (layout 'wrap-content 'wrap-content 0 'centre) + (lambda () (list (update-widget 'text-view 999 'hide 0)))) + (button (make-id "but3") "Boo" 20 (layout 'wrap-content 'wrap-content 0 'centre) + (lambda () (list (update-widget 'text-view 999 'hide 0)))))) + + (text-view (make-id "view1") "This is the title" 10 fillwrap) + (text-view (make-id "view2") "More texht" 40 fillwrap) + (text-view (make-id "view3") "event More texht" 30 fillwrap) + + (button (make-id "but2") "Click me also pretty please" 20 fillwrap + (lambda () + (list + (toast "hello dudes") + (start-activity "two" 2) + (update-widget 'text-view (get-id "view1") 'text "I have been updated")))) + (seek-bar (make-id "seek") 100 fillwrap + (lambda (v) + (list + (update-widget 'text-view (get-id "view2") 'text (number->string v)) + (update-widget 'canvas (get-id "canvas") 'drawlist + (list (drawlist-line '(255 0 0) 10 (list 0 0 v 100)))) + ))) + + (canvas (make-id "canvas") + (layout 200 200 1 'centre) + (list + (drawlist-line '(255 0 0) 5 '(0 0 100 100)))) + + (button (make-id "but4") "one two" 10 fillwrap + (lambda () + '())))) + + (lambda (activity) + (activity-layout activity)) + (lambda (activity) '()) + (lambda (activity) '()) + (lambda (activity) '()) + (lambda (activity) '()) + (lambda (activity) '()) + (lambda (activity) '())) + + (activity + "two" + (linear-layout + (make-id "top") + 'vertical + (layout 'fill-parent 'fill-parent 1 'left) + (list + (spinner (make-id "spinner") (list "one" "two" "three" "cows") fillwrap + (lambda (v) + (list (toast "what's up doc?")))) + (image-view (make-id "face") "face" wrap) + (button (make-id "exit") "Exit" 50 fillwrap + (lambda () + (list (finish-activity 99)))))) + + (lambda (activity) + (activity-layout activity)) + (lambda (activity) '()) + (lambda (activity) '()) + (lambda (activity) '()) + (lambda (activity) '()) + (lambda (activity) '()) + (lambda (activity) '()))) diff --git a/symbaidb/assets/testing.scm b/symbaidb/assets/testing.scm new file mode 100644 index 0000000000000000000000000000000000000000..eae8a4f24ef1b494e48ae825ea797cc0042172ae --- /dev/null +++ b/symbaidb/assets/testing.scm @@ -0,0 +1 @@ +(start-activity "calc" 2) diff --git a/symbaidb/assets/translations.csv b/symbaidb/assets/translations.csv new file mode 100644 index 0000000000000000000000000000000000000000..b067ab1bf3c346017d7d75dfe46711551b3bc991 --- /dev/null +++ b/symbaidb/assets/translations.csv @@ -0,0 +1,266 @@ +"Code (don't change these)","English","Khasi","Hindi", +"start","Symbai",,, +"next","Next",,, +"yes","Yes",,, +"no","No",,, +"unanswered","Unanswered",,, +"not-set","Not set",,, +"details-next","Next",,, +"family-next","Next",,, +"migration-next","Next",,, +"income-next","Next",,, +"gene-next","Next",,, +"social-next","Next",,, +"friendship-next","Next",,, +"agreement-next","Next",,, +"village"," Village"," ",, +"household"," Household"," ",, +"households"," Households"," ",, +"individual"," Individual"," ",, +"individuals"," Individuals"," ",, +"add-item-to-list",0," ",, +"default-village-name"," New village"," ",, +"title"," Symbai"," Symbai"," Symbai"," " +"sync"," Sync"," Sync"," Sync"," " +"languages"," Choose language"," Choose language"," Choose language"," " +"english"," English"," English"," English"," " +"khasi"," Khasi"," Khasi"," Khasi"," " +"hindi"," Hindi"," Hindi"," Hindi"," " +"user-id"," User ID"," User ID"," User ID"," " +"save"," Save"," Save"," Save"," " +"back"," Back"," Back"," Back"," " +"off"," Off"," Off"," Off"," " +"villages"," Villages"," Villages"," Villages"," " +"list-empty"," List empty"," ",, +"delete"," Delete"," ",, +"delete-are-you-sure"," Are you sure you want to delete this?"," ",, +"save-are-you-sure"," Are you sure you want to save changes?"," ",, +"quick-name"," New person name"," ",, +"quick-add"," Quick add"," ",, +"find-individual"," Find individual"," ",, +"filter"," Filter"," ",, +"filter-switch","Run filter",,, +"off"," Off"," Off"," Off"," " +"name"," Name","Kyrteng",, +"sync-all"," Sync me!"," ",, +"sync-syncall"," Sync everything"," ",, +"export-data"," Exporting data"," ",, +"sync-download"," Download main DB"," ",, +"sync-export"," Email main DB"," ",, +"email-local"," Email local DB"," ",, +"debug"," Debug"," ",, +"sync-back"," Back"," ",, +"sync-prof"," Profile"," ",, +"village-name"," Village name"," Village name"," Village name"," " +"block"," Block"," Block"," Block"," " +"district"," District"," District"," District"," " +"car"," Accessible by car"," ",, +"household-list"," Household list"," ",, +"amenities"," Amenities"," ",, +"school"," School"," ",, +"present"," Present"," ",, +"closest-access"," Closest place of access"," ",, +"house-gps"," GPS"," ",, +"toilet-gps"," GPS"," ",, +"school-in-village","In Village",,, +"school"," School"," ",, +"school-closest-access"," Closest access"," ",, +"school-gps"," GPS"," ",, +"hospital-in-village","In Village",,, +"hospital"," Hospital/Health care centre"," ",, +"hospital-closest-access"," Closest access"," ",, +"hospital-gps"," GPS"," ",, +"Post-office-in-village","In Village",,, +"post-office"," Post Office"," ",, +"post-office-closest-access"," Closest access"," ",, +"post-office-gps"," GPS"," ",, +"railway-station-in-village","In Village",,, +"railway-station"," Railway station"," ",, +"railway-station-closest-access"," Closest access"," ",, +"railway-station-gps"," GPS"," ",, +"State-bus-service-in-village","In Village",,, +"state-bus-service"," Inter-state bus service"," ",, +"state-bus-service-closest-access"," Closest access"," ",, +"state-bus-service-gps"," GPS"," ",, +"District-bus-service-in-village","In Village",,, +"district-bus-service"," Inter-village/district bus service"," ",, +"district-bus-service-closest-access"," Closest access"," ",, +"district-bus-service-gps"," GPS"," ",, +"Panchayat-in-village","In Village",,, +"panchayat"," Village Panchayat Office"," ",, +"panchayat-closest-access"," Closest access"," ",, +"panchayat-gps"," GPS"," ",, +"NGO-in-village","In Village",,, +"NGO"," Presence of NGO's working with them"," ",, +"NGO-closest-access"," Closest access"," ",, +"NGO-gps"," GPS"," ",, +"market-in-village","In Village",,, +"market"," Market"," ",, +"market-closest-access"," Closest access"," ",, +"market-gps"," GPS"," ",, +"household-name"," Household name"," ",, +"default-household-name"," A household"," ",, +"location"," House location"," ",, +"elevation"," Elevation"," ",, +"toilet-location"," Toilet location"," ",, +"children"," Children"," ",, +"male"," Male","Shynrang",, +"female"," Female","Kynthei",, +"num-pots"," Number of pots"," ",, +"adults"," Adults"," ",, +"add-individual"," Add individual"," ",, +"default-individual-name"," A person"," ",, +"default-family-name"," A family"," ",, +"default-photo-id"," ???"," ",, +"name-display"," Name","Kyrteng",, +"photo-id-display"," Photo ID","Nombor dur ID",, +"family-display"," Family","Family/Clan",, +"details-button"," Details"," ",, +"family-button"," Family","Family/Clan",, +"migration-button"," Migration"," ",, +"friendship-button","Friendship",,, +"income-button"," Income"," ",, +"genealogy-button"," Genealogy"," ",, +"social-button"," Social"," ",, +"agreement-button"," Agreement"," ",, +"is-a-child"," Child"," ",, +"change-photo"," Change photo"," ",, +"details-name"," Name","Kyrteng",, +"details-first-name","Name","Kyrteng",, +"details-photo-id"," Photo ID","Nombor dur ID",, +"details-family"," Family"," ",, +"tribe"," Tribe","Jaidbynriew:",, +"sub-tribe"," Sub tribe","Tynrai Jaidbynriew",, +"khasi"," Khasi"," ",, +"khynriam"," Khynriam"," ",, +"pnar"," Pnar"," ",, +"bhoi"," Bhoi"," ",, +"war"," War"," ",, +"other"," Other"," ",, +"age"," Age","Ka rta",, +"gender"," Gender","U/ka",, +"education"," Education","Jingpule",, +"illiterate"," Illiterate","Bym Nang/Bymstad",, +"literate"," Literate","Lah Nang/Lahtip",, +"primary"," Primary 1-5","Biang 1-5",, +"middle"," Middle 6-8","Ba Pdeng 6-8",, +"high"," High 9-10","Lah Khamstad 9-10",, +"secondary"," Higher Secondary","Lah stad",, +"university"," University","La pyndep university",, +"spouse"," Spouse"," ",, +"change-id"," Change"," ",, +"head-of-house"," Head of house"," ",, +"marital-status"," Marital status"," ",, +"ever-married"," Ever married"," ",, +"currently-married"," Currently married"," ",, +"currently-single"," Currently single"," ",, +"seperated"," Seperated/divorced"," ",, +"times-married"," How many times married"," ",, +"change-spouse"," Change/add spouse"," ",, +"children-living"," Living"," ",, +"children-dead"," Dead"," ",, +"children-together"," Living together"," ",, +"children-apart"," Living apart"," ",, +"residence-after-marriage"," Residence after marriage"," ",, +"birthplace"," Birthplace"," ",, +"spouse-village"," Spouses natal village"," ",, +"num-siblings"," Number of living siblings of the same sex born from same mother"," ",, +"birth-order"," Birth order amoung currently living same sex siblings born from same mother"," ",, +"length-time"," Length of time lived in this village (years)"," ",, +"place-of-birth"," Place of birth"," ",, +"num-residence-changes"," Number of time place of residence changed since birth"," ",, +"village-visits-month"," Number of times you have visited another village in the last month"," ",, +"village-visits-year"," Number of times you have visited another village in the last year (i.e. between last summer and this summer)"," ",, +"occupation"," Occupation"," ",, +"occupation"," Occupation"," ",, +"num-people-in-house"," People living in house"," ",, +"contribute"," Do you contribute to the family earnings?"," ",, +"own-land"," Do you own land?"," ",, +"rent-land"," Do you rent out your land?"," ",, +"hire-land"," Do you hire someone else's land to work on?"," ",, +"crops-detail","List the crops you grew last year:",,, +"crops"," Crops"," ",, +"unit"," Unit"," ",, +"quantity"," Quantity"," ",, +"used-or-eaten"," Used/Eaten"," ",, +"sold"," Sold"," ",, +"seed"," Seed (hybrid/local)"," ",, +"house-type"," Type of house"," ",, +"concrete"," Concrete"," ",, +"tin"," Tin"," ",, +"thatched"," Thatched"," ",, +"loan"," Outstanding loans"," ",, +"earning"," How much do you earn for one day's labour?"," ",, +"in-the-home"," In the home"," ",, +"radio"," Radio"," ",, +"tv"," TV"," ",, +"mobile"," Mobile phone"," ",, +"visit-market"," How many times do you visit the tribal market?"," ",, +"town-sell","How many times a month do you visit your nearest city or town to buy or sell something?"," ",, +"default-crop-name"," A crop"," ",, +"crop-name"," Crop name"," ",, +"crop-unit"," Crop unit"," ",, +"crop-used"," Used or eaten"," ",, +"crop-sold"," Sold"," ",, +"crop-seed"," Seed"," ",, +"mother"," Mother"," ",, +"father"," Father"," ",, +"change-mother"," Change mother"," ",, +"change-father"," Change father"," ",, +"alive"," Alive"," ",, +"sex"," Sex"," ",, +"social-type"," Type"," ",, +"friendship"," Friendship"," ",, +"knowledge"," Knowledge"," ",, +"prestige"," Prestige"," ",, +"social-one"," One"," ",, +"social-two"," Two"," ",, +"social-three"," Three"," ",, +"social-four"," Four"," ",, +"social-five"," Five"," ",, +"social-nickname","Name",,, +"social-relationship"," Relation"," ",, +"social-residence"," Residence"," ",, +"social-strength"," Strength"," ",, +"mother"," Mother"," ",, +"father"," Father"," ",, +"sister"," Sister"," ",, +"brother"," Brother"," ",, +"spouse"," Spouse"," ",, +"children"," Children"," ",, +"co-wife"," Co-wife"," ",, +"spouse-mother"," Spouse's mother"," ",, +"spouse-father"," Spouse's father"," ",, +"spouse-brother-wife"," Spouse's brother's wife"," ",, +"spouse-sister-husband"," Spouse's sister's husband"," ",, +"friend"," Friend"," ",, +"neighbour"," Neighbour"," ",, +"same"," Same"," ",, +"daily"," Daily"," ",, +"weekly"," Weekly"," ",, +"monthly"," Monthly"," ",, +"less"," Less"," ",, +"child-name","Name",,, +"child-gender","Gender",,, +"child-age","Age",,, +"child-home","Lives at home",,, +"child-alive","Alive",,, +"default-child-name","A child",,, +"move-button","Move household",,, +"move-household","Pick a new household",,, +"house-id","House ID",,, +"photo-id","Photo ID",,, +"add-are-you-sure","Are you sure you want to add this individual?",,, +"gps-are-you-sure","Are you sure you want to record your current position?",,, +"gps-are-you-sure-2","Please confirm again...",,, +"current-village","Your current village",,, +"num-children","Number of children",,, +"occupation-agriculture","Agriculture",,, +"occupation-gathering","Gathering",,, +"occupation-labour","Labour",,, +"occupation-cows","Cows",,, +"occupation-fishing","Fishing",,, +"occupation-other","Other",,, +"friendship-question","LIST UP TO FIVE PERSONS whom you have really liked to talk to in the last year. They can be of either sex. They can be friends, neighbours, relatives, co-wives; they can live in this village or elsewhere; anyone you like to talk to. ",,, +"prestige-question","LIST UP TO FIVE PERSONS who you think are the most respected in the village: ",,, +"knowledge-question","LIST UP TO FIVE PERSONS who you think are the most knowledgeable in the village:",,, diff --git a/symbaidb/assets/translations.scm b/symbaidb/assets/translations.scm new file mode 100644 index 0000000000000000000000000000000000000000..17ea09e4d71a4b567a3d3cb84422c89cb68b847a --- /dev/null +++ b/symbaidb/assets/translations.scm @@ -0,0 +1,281 @@ +(define i18n-text + (list + (list 'start (list "Symbai" )) + (list 'next (list "Next" )) + (list 'yes (list "Yes" )) + (list 'no (list "No" )) + (list 'not-answered (list "Unanswered" )) + (list 'not-set (list "Not set" )) + (list 'years-old (list " years old")) + (list 'birth-year (list "Birth year")) + (list 'agree-record (list "Record")) + (list 'agree-playback (list "Play")) + (list 'photo-agree-record (list "Record")) + (list 'photo-agree-playback (list "Play")) + (list 'general-agreement-text (list "Blah blah...")) + (list 'photo-agreement-text (list "Blah blah...")) + (list 'village-notes (list "Notes")) + (list 'individual-notes (list "Notes")) + (list 'household-notes (list "Notes")) + (list 'crop-notes (list "Notes")) + (list 'child-notes (list "Notes")) + (list 'details-next (list "Next" )) + (list 'family-next (list "Next" )) + (list 'migration-next (list "Next" )) + (list 'income-next (list "Next" )) + (list 'gene-next (list "Next" )) + (list 'social-next (list "Next" )) + (list 'friendship-next (list "Next" )) + (list 'agreement-next (list "Next" )) + (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 "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 'filter-switch (list "Run 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" "" )) + (list 'family-button (list "Family" "Family/Clan" )) + (list 'migration-button (list "Migration" "" )) + (list 'friendship-button (list "Friendship" )) + (list 'income-button (list "Income" "" )) + (list 'genealogy-button (list "Genealogy" "" )) + (list 'social-button (list "Social" "" )) + (list 'agreement-button (list "Agreement" "" )) + (list 'is-a-child (list "Child" "" )) + (list 'change-photo (list "Change photo" "" )) + (list 'details-name (list "Name" "Kyrteng" )) + (list 'details-first-name (list "Name" "Kyrteng" )) + (list 'details-photo-id (list "Photo ID" "Nombor dur ID" )) + (list 'details-family (list "Family" "" )) + (list 'tribe (list "Tribe" "Jaidbynriew:" )) + (list 'sub-tribe (list "Sub tribe" "Tynrai Jaidbynriew" )) + (list 'khasi (list "Khasi" "" )) + (list 'khynriam (list "Khynriam" "" )) + (list 'pnar (list "Pnar" "" )) + (list 'bhoi (list "Bhoi" "" )) + (list 'war (list "War" "" )) + (list 'other (list "Other" "" )) + (list 'age (list "Age" "Ka rta" )) + (list 'gender (list "Gender" "U/ka" )) + (list 'education (list "Education" "Jingpule" )) + (list 'illiterate (list "Illiterate" "Bym Nang/Bymstad" )) + (list 'literate (list "Literate" "Lah Nang/Lahtip" )) + (list 'primary (list "Primary 1-5" "Biang 1-5" )) + (list 'middle (list "Middle 6-8" "Ba Pdeng 6-8" )) + (list 'high (list "High 9-10" "Lah Khamstad 9-10" )) + (list 'secondary (list "Higher Secondary" "Lah stad" )) + (list 'university (list "University" "La pyndep university" )) + (list 'spouse (list "Spouse" "" )) + (list 'change-id (list "Change" "" )) + (list 'head-of-house (list "Head of house" "" )) + (list 'marital-status (list "Marital status" "" )) + (list 'ever-married (list "Ever married" "" )) + (list 'currently-married (list "Currently married" "" )) + (list 'currently-single (list "Currently single" "" )) + (list 'seperated (list "Seperated/divorced" "" )) + (list 'times-married (list "How many times married" "" )) + (list 'change-spouse (list "Change/add spouse" "" )) + (list 'children-living (list "Living" "" )) + (list 'children-dead (list "Dead" "" )) + (list 'children-together (list "Living together" "" )) + (list 'children-apart (list "Living apart" "" )) + (list 'residence-after-marriage (list "Residence after marriage" "" )) + (list 'birthplace (list "Birthplace" "" )) + (list 'spouse-village (list "Spouses natal village" "" )) + (list 'num-siblings (list "Number of living siblings of the same sex born from same mother" "" )) + (list 'birth-order (list "Birth order amoung currently living same sex siblings born from same mother" "" )) + (list 'length-time (list "Length of time lived in this village (years)" "" )) + (list 'place-of-birth (list "Place of birth" "" )) + (list 'num-residence-changes (list "Number of time place of residence changed since birth" "" )) + (list 'village-visits-month (list "Number of times you have visited another village in the last month" "" )) + (list 'village-visits-year (list "Number of times you have visited another village in the last year (i.e. between last summer and this summer)" "" )) + (list 'occupation (list "Occupation" "" )) + (list 'occupation (list "Occupation" "" )) + (list 'num-people-in-house (list "People living in house" "" )) + (list 'contribute (list "Do you contribute to the family earnings?" "" )) + (list 'own-land (list "Do you own land?" "" )) + (list 'rent-land (list "Do you rent out your land?" "" )) + (list 'hire-land (list "Do you hire someone else's land to work on?" "" )) + (list 'crops-detail (list "List the crops you grew last year:" )) + (list 'crops (list "Crops" "" )) + (list 'unit (list "Unit" "" )) + (list 'quantity (list "Quantity" "" )) + (list 'used-or-eaten (list "Used/Eaten" "" )) + (list 'sold (list "Sold" "" )) + (list 'seed (list "Seed (hybrid/local)" "" )) + (list 'house-type (list "Type of house" "" )) + (list 'concrete (list "Concrete" "" )) + (list 'tin (list "Tin" "" )) + (list 'thatched (list "Thatched" "" )) + (list 'loan (list "Outstanding loans" "" )) + (list 'earning (list "How much do you earn for one day's labour?" "" )) + (list 'in-the-home (list "In the home" "" )) + (list 'radio (list "Radio" "" )) + (list 'tv (list "TV" "" )) + (list 'mobile (list "Mobile phone" "" )) + (list 'visit-market (list "How many times do you visit the tribal market?" "" )) + (list 'town-sell (list "How many times a month do you visit your nearest city or town to buy or sell something?" "" )) + (list 'default-crop-name (list "crop" "" )) + (list 'crop-name (list "Crop name" "" )) + (list 'crop-unit (list "Crop unit" "" )) + (list 'crop-used (list "Used or eaten" "" )) + (list 'crop-sold (list "Sold" "" )) + (list 'crop-seed (list "Seed" "" )) + (list 'mother (list "Mother" "" )) + (list 'father (list "Father" "" )) + (list 'change-mother (list "Change mother" "" )) + (list 'change-father (list "Change father" "" )) + (list 'alive (list "Alive" "" )) + (list 'sex (list "Sex" "" )) + (list 'social-type (list "Type" "" )) + (list 'friendship (list "Friendship" "" )) + (list 'knowledge (list "Knowledge" "" )) + (list 'prestige (list "Prestige" "" )) + (list 'social-one (list "One" "" )) + (list 'social-two (list "Two" "" )) + (list 'social-three (list "Three" "" )) + (list 'social-four (list "Four" "" )) + (list 'social-five (list "Five" "" )) + (list 'social-nickname (list "Name" )) + (list 'social-relationship (list "Relation" "" )) + (list 'social-residence (list "Residence" "" )) + (list 'social-strength (list "Strength" "" )) + (list 'mother (list "Mother" "" )) + (list 'father (list "Father" "" )) + (list 'sister (list "Sister" "" )) + (list 'brother (list "Brother" "" )) + (list 'spouse (list "Spouse" "" )) + (list 'children (list "Children" "" )) + (list 'co-wife (list "Co-wife" "" )) + (list 'spouse-mother (list "Spouse's mother" "" )) + (list 'spouse-father (list "Spouse's father" "" )) + (list 'spouse-brother-wife (list "Spouse's brother's wife" "" )) + (list 'spouse-sister-husband (list "Spouse's sister's husband" "" )) + (list 'friend (list "Friend" "" )) + (list 'neighbour (list "Neighbour" "" )) + (list 'same (list "Same" "" )) + (list 'daily (list "Daily" "" )) + (list 'weekly (list "Weekly" "" )) + (list 'monthly (list "Monthly" "" )) + (list 'less (list "Less" "" )) + (list 'child-name (list "Name" )) + (list 'child-gender (list "Gender" )) + (list 'child-age (list "Age" )) + (list 'child-home (list "Lives at home" )) + (list 'child-alive (list "Alive" )) + (list 'default-child-name (list "child" )) + (list 'move-button (list "Move household" )) + (list 'move-household (list "Pick a new household" )) + (list 'house-id (list "House ID" )) + (list 'photo-id (list "Photo ID" )) + (list 'add-are-you-sure (list "Are you sure you want to add this individual?" )) + (list 'gps-are-you-sure (list "Are you sure you want to record your current position?" )) + (list 'gps-are-you-sure-2 (list "Please confirm again..." )) + (list 'current-village (list "Your current village" )) + (list 'num-children (list "Number of children" )) + (list 'occupation-agriculture (list "Agriculture" )) + (list 'occupation-gathering (list "Gathering" )) + (list 'occupation-labour (list "Labour" )) + (list 'occupation-cows (list "Cows" )) + (list 'occupation-fishing (list "Fishing" )) + (list 'occupation-other (list "Other" )) + (list 'friendship-question (list "LIST UP TO FIVE PERSONS whom you have really liked to talk to in the last year. They can be of either sex. They can be friend, neighbours, relatives, co-wives; they can live in this village or elsewhere; anyone you like to talk to." "" )) + (list 'prestige-question (list "LIST UP TO FIVE PERSONS who you think are the most respected in the village:" )) + (list 'knowledge-question (list "LIST UP TO FIVE PERSONS who you think are the most knowledgeable in the village:" )) + )) diff --git a/symbaidb/assets/unit-tests.scm b/symbaidb/assets/unit-tests.scm new file mode 100644 index 0000000000000000000000000000000000000000..39167799bc8c4590fe7eb8811fb125f675d1b3a2 --- /dev/null +++ b/symbaidb/assets/unit-tests.scm @@ -0,0 +1,189 @@ +(asserteq "filter" (filter (lambda (i) (odd? i)) (list 0 1 2 3)) (list 1 3)) +(asserteq "sort" (sort (list 3 2 0 1) <) (list 0 1 2 3)) +(asserteq "find" (find 3 (list '(3 30) '(2 20) '(0 100) '(1 10))) (list 3 30)) +(asserteq "build-list" (build-list (lambda (i) (* i 2)) 5) (list 0 2 4 6 8)) +(asserteq "foldl" (foldl (lambda (i r) (+ i r)) 0 (list 1 2 3 4)) 10) +(asserteq "insert-to" (insert-to 999 3 (list 0 1 2 3 4)) (list 0 1 2 999 3 4)) +(asserteq "list-replace" (list-replace (list 1 2 3 4) 2 100) (list 1 2 100 4)) +(asserteq "insert" (insert 4 < (list 2 5 100)) (list 2 4 5 100)) + +(assert "date<" (date< (list 20 12 2010) (list 25 12 2010))) +(asserteq "date->string" (date->string (list 20 12 2012)) "20/12/2012") + +(asserteq "scheme->json" (scheme->json (list 10)) "[10]") +(asserteq "scheme->json2" (scheme->json (list 10 20)) "[10, 20]") +(asserteq "scheme->json3" (scheme->json (list (list "one" "two") 10)) + "[[\"one\", \"two\"], 10]") +(asserteq "scheme->json4" (scheme->json (list)) "[]") +(asserteq "scheme->json5" (scheme->json 'sym) "\"sym\"") +(asserteq "scheme->json6" (scheme->json (list #t #f)) "[true, false]") +(asserteq "assoc->json" (assoc->json '((one . 1) (two . "three"))) + "{\n\"one\": 1,\n\"two\": \"three\"\n}") + + +;; db +(msg "testing db") +(define db "unit-test.db") +(db-open db) + +(define (feq a b) + (< (abs (- a b)) 0.001)) + +;;(msg (db-status db)) + +;; test low level sql +(db-exec db "create table unittest ( id integer primary key autoincrement, name varchar(256), num int, r real )") + +(define id (db-insert db "insert into unittest values (null, ?, ?, ?)" "hello" 23 1.1)) +(asserteq "sql autoinc" (+ id 1) (db-insert db "insert into unittest values (null, ?, ?, ?)" "hello2" 26 2.3)) + +(let ((q (db-exec db "select * from unittest"))) + (assert "sql length" (> (length q) 2))) + +(let ((q (db-exec db "select * from unittest where id = ?" id))) + (asserteq "sql select one" (length q) 2) + (assert "sql select two" (vector? (car q))) + (asserteq "sql select 3" (vector-ref (cadr q) 2) 23) + (assert "sql select 4" (feq (vector-ref (cadr q) 3) 1.1))) + +(db-exec db "update unittest set name=? where id = ?" "bob" id) + +(let ((q (db-exec db "select * from unittest where id = ?" id))) + (asserteq "sql update" (vector-ref (cadr q) 1) "bob")) + +(db-exec db "update unittest set name=? where id = ?" "Robert'); DROP TABLE unittest;--" id) + +(let ((q (db-exec db "select * from unittest where id = ?" id))) + (asserteq "bobby tables sql injection" (vector-ref (cadr q) 1) "Robert'); DROP TABLE unittest;--")) + + +;; test the entity attribute value system +(define table "eavunittest") +(setup db table) + +(asserteq "ktv one" (stringify-value (ktv "one" "varchar" "two")) "'two'") +(asserteq "ktv 2" (stringify-value (ktv "one" "int" 3)) "3") +(asserteq "ktv 3" (stringify-value-url (ktv "one" "varchar" "two")) "two") +(asserteq "ktv 4" (stringify-value-url (ktv "one" "int" 3)) "3") + +(asserteq "select first" (select-first db "select name from unittest where id = ?" (+ id 1)) + "hello2") + +(define e (insert-entity db table "thing" "me" (list (ktv "param1" "varchar" "bob") + (ktv "param2" "int" 30) + (ktv "param3" "real" 3.141)))) + +(asserteq "eav ent type" (get-entity-type db table e) "thing") + +(let ((e (get-entity db table e))) + (asserteq "entity get 1" (ktv-get e "param1") "bob") + (asserteq "entity get 2" (ktv-get e "param2") 30) + (assert "entity get 3" (feq (ktv-get e "param3") 3.141))) + +(update-value db table e (ktv "param1" "varchar" "fred")) + +(let ((e (get-entity db table e))) + (asserteq "update value 1" (ktv-get e "param1") "fred") + (asserteq "update value 2" (ktv-get e "param2") 30)) + +(assert "all-entities" (> (length (all-entities db table "thing")) 0)) + +(update-entity db table e (list (ktv "param1" "varchar" "wotzit") + (ktv "param2" "int" 1))) + +(let ((e (get-entity db table e))) + (asserteq "update-entity 1" (ktv-get e "param1") "wotzit") + (asserteq "update-entity 2" (ktv-get e "param2") 1)) + +(update-entity db table e (list (ktv "param3" "real" 3.3))) + +(let ((e (get-entity db table e))) + (asserteq "update-entity 3" (ktv-get e "param1") "wotzit") + (asserteq "update-entity 4" (ktv-get e "param2") 1) + (assert "update-entity 5" (feq (ktv-get e "param3") 3.3))) + +(define e2 (insert-entity db table "thing" "me" + (list (ktv "param1" "varchar" "bob") + (ktv "param2" "int" 30) + (ktv "param3" "real" 3.141) + (ktv "param4" "int" 0)))) + +(let ((e (get-entity db table e2))) + (msg e) + (asserteq "new entity 1" (ktv-get e "param1") "bob") + (asserteq "new entity 2" (ktv-get e "param2") 30) + (assert "new entity 3" (feq (ktv-get e "param3") 3.141)) + (asserteq "new entity 3" (ktv-get e "param4") 0)) + +;; test the versioning +(asserteq "dirty flag" (get-entity-dirty db table e2) 1) +(let ((uid (get-unique-id db table e2))) + (update-entity-clean db table uid)) +(asserteq "dirty flag post clean" (get-entity-dirty db table e2) 0) +(asserteq "versioning" (get-entity-version db table e) 2) +(assert "dirty" (> (length (dirty-entities db table)) 0)) + +(for-each + (lambda (e) + (update-entity-clean + db table + (list-ref (car e) 1))) + (dirty-entities db table)) + +(asserteq "cleaning" (length (dirty-entities db table)) 0) + +(msg (db-status db)) + +(msg "testing some interface building...") + +(setup db "sync") + +(define i (insert-entity + db "sync" "pack" "user" + (list (ktv "name" "varchar" "pack one")))) + +(define p (get-entity db "sync" i)) + +(msg (ktv-get p "unique_id")) + +(define (make-mongoose name) + (insert-entity + db "sync" "mongoose" (ktv-get p "unique_id") + (list + (ktv "name" "varchar" name) + (ktv "gender" "varchar" "Female") + (ktv "litter-code" "varchar" "34") + (ktv "chip-code" "varchar" "34") + (ktv "pack-id" "varchar" "unique_id") + ))) + +(make-mongoose "bob") +(make-mongoose "fred") +(make-mongoose "arnold") +(make-mongoose "lucy") +(make-mongoose "doris") +(make-mongoose "kylie") +(make-mongoose "jenny") + + +(for-each + (lambda (fragment) + (msg "calling fragment" fragment) + (fragment-callback 'on-create fragment '(""))) + (build-list + (lambda (i) + (choose (list + "pf-timer" + "pf-scan1" + "events" + "pf-timer" + "ev-pupfeed" + "ev-pupcare" + "ev-pupfind" + "ev-pupaggr" + "ev-grpint" + "ev-grpalarm" + "ev-grpmov"))) + 100)) + + diff --git a/symbaidb/build.xml b/symbaidb/build.xml new file mode 100644 index 0000000000000000000000000000000000000000..d6c311ca6f94fc4ede6d99fe6bb36f3e03d37641 --- /dev/null +++ b/symbaidb/build.xml @@ -0,0 +1,92 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/symbaidb/local.properties b/symbaidb/local.properties new file mode 100644 index 0000000000000000000000000000000000000000..066d6029e341e10245741c886a9d204b006c0a6a --- /dev/null +++ b/symbaidb/local.properties @@ -0,0 +1,10 @@ +# This file is automatically generated by Android Tools. +# Do not modify this file -- YOUR CHANGES WILL BE ERASED! +# +# This file must *NOT* be checked into Version Control Systems, +# as it contains information specific to your local configuration. + +# location of the SDK. This is only used by Ant +# For customization when using a Version Control System, please read the +# header note. +sdk.dir=/home/dave/opt/android diff --git a/symbaidb/proguard-project.txt b/symbaidb/proguard-project.txt new file mode 100644 index 0000000000000000000000000000000000000000..f2fe1559a217865a5454add526dcc446f892385b --- /dev/null +++ b/symbaidb/proguard-project.txt @@ -0,0 +1,20 @@ +# To enable ProGuard in your project, edit project.properties +# to define the proguard.config property as described in that file. +# +# Add project specific ProGuard rules here. +# By default, the flags in this file are appended to flags specified +# in ${sdk.dir}/tools/proguard/proguard-android.txt +# You can edit the include path and order by changing the ProGuard +# include property in project.properties. +# +# For more details, see +# http://developer.android.com/guide/developing/tools/proguard.html + +# Add any project specific keep options here: + +# If your project uses WebView with JS, uncomment the following +# and specify the fully qualified class name to the JavaScript interface +# class: +#-keepclassmembers class fqcn.of.javascript.interface.for.webview { +# public *; +#} diff --git a/symbaidb/project.properties b/symbaidb/project.properties new file mode 100644 index 0000000000000000000000000000000000000000..7e688ffdffed7d5b687ca48ac476db3ca7253085 --- /dev/null +++ b/symbaidb/project.properties @@ -0,0 +1,15 @@ +# This file is automatically generated by Android Tools. +# Do not modify this file -- YOUR CHANGES WILL BE ERASED! +# +# This file must be checked in Version Control Systems. +# +# To customize properties used by the Ant build system edit +# "ant.properties", and override values to adapt the script to your +# project structure. +# +# To enable ProGuard to shrink and obfuscate your code, uncomment this (available properties: sdk.dir, user.home): +#proguard.config=${sdk.dir}/tools/proguard/proguard-android.txt:proguard-project.txt + +# Project target. +target=Google Inc.:Google APIs:18 +android.library.reference.1=../../../starwisp diff --git a/symbaidb/res/animator/card_flip_left_in.xml b/symbaidb/res/animator/card_flip_left_in.xml new file mode 100644 index 0000000000000000000000000000000000000000..5c2ba0d97795b57ed9f90c736be5febb4ddcd9db --- /dev/null +++ b/symbaidb/res/animator/card_flip_left_in.xml @@ -0,0 +1,24 @@ + + + + + + + + + + diff --git a/symbaidb/res/animator/card_flip_left_out.xml b/symbaidb/res/animator/card_flip_left_out.xml new file mode 100644 index 0000000000000000000000000000000000000000..1d77a99c77d80bf02ac1f31a09e295974a07077d --- /dev/null +++ b/symbaidb/res/animator/card_flip_left_out.xml @@ -0,0 +1,17 @@ + + + + + + + diff --git a/symbaidb/res/animator/card_flip_right_in.xml b/symbaidb/res/animator/card_flip_right_in.xml new file mode 100644 index 0000000000000000000000000000000000000000..a1408ed8258c803a54082897847bde7a7070d73c --- /dev/null +++ b/symbaidb/res/animator/card_flip_right_in.xml @@ -0,0 +1,24 @@ + + + + + + + + + + diff --git a/symbaidb/res/animator/card_flip_right_out.xml b/symbaidb/res/animator/card_flip_right_out.xml new file mode 100644 index 0000000000000000000000000000000000000000..d0c9625395e44782ee848c9d7a83ab3bd41b4fd3 --- /dev/null +++ b/symbaidb/res/animator/card_flip_right_out.xml @@ -0,0 +1,17 @@ + + + + + + + diff --git a/symbaidb/res/drawable-hdpi/ic_launcher.png b/symbaidb/res/drawable-hdpi/ic_launcher.png new file mode 100644 index 0000000000000000000000000000000000000000..96a442e5b8e9394ccf50bab9988cb2316026245d Binary files /dev/null and b/symbaidb/res/drawable-hdpi/ic_launcher.png differ diff --git a/symbaidb/res/drawable-ldpi/ic_launcher.png b/symbaidb/res/drawable-ldpi/ic_launcher.png new file mode 100644 index 0000000000000000000000000000000000000000..99238729d8753585237a65b91c7cde426c90baef Binary files /dev/null and b/symbaidb/res/drawable-ldpi/ic_launcher.png differ diff --git a/symbaidb/res/drawable-mdpi/ic_launcher.png b/symbaidb/res/drawable-mdpi/ic_launcher.png new file mode 100644 index 0000000000000000000000000000000000000000..359047dfa4ed206e41e2354f9c6b307e713efe32 Binary files /dev/null and b/symbaidb/res/drawable-mdpi/ic_launcher.png differ diff --git a/symbaidb/res/drawable-xhdpi/ic_launcher.png b/symbaidb/res/drawable-xhdpi/ic_launcher.png new file mode 100644 index 0000000000000000000000000000000000000000..71c6d760f05183ef8a47c614d8d13380c8528499 Binary files /dev/null and b/symbaidb/res/drawable-xhdpi/ic_launcher.png differ diff --git a/symbaidb/res/drawable/bg.png b/symbaidb/res/drawable/bg.png new file mode 100644 index 0000000000000000000000000000000000000000..f62382299c1a2a42eee237caea703b88eec303a6 Binary files /dev/null and b/symbaidb/res/drawable/bg.png differ diff --git a/symbaidb/res/drawable/bg_style.xml b/symbaidb/res/drawable/bg_style.xml new file mode 100644 index 0000000000000000000000000000000000000000..5b5f2828ccee61d7185d3d165b508ed349ac3e08 --- /dev/null +++ b/symbaidb/res/drawable/bg_style.xml @@ -0,0 +1,5 @@ + + diff --git a/symbaidb/res/drawable/bgpaw.png b/symbaidb/res/drawable/bgpaw.png new file mode 100644 index 0000000000000000000000000000000000000000..8694ead70a1c0b60e3510942515842959681f691 Binary files /dev/null and b/symbaidb/res/drawable/bgpaw.png differ diff --git a/symbaidb/res/drawable/cross.png b/symbaidb/res/drawable/cross.png new file mode 100644 index 0000000000000000000000000000000000000000..337ff5252e7b4160225b2c9ab79ac86642d98c36 Binary files /dev/null and b/symbaidb/res/drawable/cross.png differ diff --git a/symbaidb/res/drawable/face.png b/symbaidb/res/drawable/face.png new file mode 100644 index 0000000000000000000000000000000000000000..3e058f32e2a136142444b1d49ea6fc3a51b58335 Binary files /dev/null and b/symbaidb/res/drawable/face.png differ diff --git a/symbaidb/res/drawable/logo.png b/symbaidb/res/drawable/logo.png new file mode 100644 index 0000000000000000000000000000000000000000..a35f436107d948b22fb84107030bc1e1da4b2f5f Binary files /dev/null and b/symbaidb/res/drawable/logo.png differ diff --git a/symbaidb/res/drawable/swarmbutton.xml b/symbaidb/res/drawable/swarmbutton.xml new file mode 100644 index 0000000000000000000000000000000000000000..7e3095dfae91bfd94bc0f37992b929534addb813 --- /dev/null +++ b/symbaidb/res/drawable/swarmbutton.xml @@ -0,0 +1,40 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/symbaidb/res/drawable/swarmspinner.xml b/symbaidb/res/drawable/swarmspinner.xml new file mode 100644 index 0000000000000000000000000000000000000000..05f71a1a02f742153f4264f5b26a0855e446f684 --- /dev/null +++ b/symbaidb/res/drawable/swarmspinner.xml @@ -0,0 +1,15 @@ + + + + + + + + + + + + + diff --git a/symbaidb/res/drawable/tick.png b/symbaidb/res/drawable/tick.png new file mode 100644 index 0000000000000000000000000000000000000000..206e1aefd97c01857fa9c2a92f8dafad3dab7cde Binary files /dev/null and b/symbaidb/res/drawable/tick.png differ diff --git a/symbaidb/res/layout/spinner_item.xml b/symbaidb/res/layout/spinner_item.xml new file mode 100644 index 0000000000000000000000000000000000000000..94eb12d39888946b9dae1626255d452e6ac30d93 --- /dev/null +++ b/symbaidb/res/layout/spinner_item.xml @@ -0,0 +1,8 @@ + + + diff --git a/symbaidb/res/raw/active.wav b/symbaidb/res/raw/active.wav new file mode 100644 index 0000000000000000000000000000000000000000..190e76c373ffc0a46b0d51c3c8064276c8b36860 Binary files /dev/null and b/symbaidb/res/raw/active.wav differ diff --git a/symbaidb/res/raw/ping.wav b/symbaidb/res/raw/ping.wav new file mode 100644 index 0000000000000000000000000000000000000000..a95ceb9fc85a47c39df9f2a8ce1b968694f1762a Binary files /dev/null and b/symbaidb/res/raw/ping.wav differ diff --git a/symbaidb/res/values/strings.xml b/symbaidb/res/values/strings.xml new file mode 100644 index 0000000000000000000000000000000000000000..42e046b36bd500e20e2043ef90daf6dc087f1b7d --- /dev/null +++ b/symbaidb/res/values/strings.xml @@ -0,0 +1,4 @@ + + + SymbaiDB + diff --git a/symbaidb/res/values/styles.xml b/symbaidb/res/values/styles.xml new file mode 100644 index 0000000000000000000000000000000000000000..a77380378f8ee164804cf584720f0f993e8a1036 --- /dev/null +++ b/symbaidb/res/values/styles.xml @@ -0,0 +1,84 @@ + + + #aaaaaa + #000000 + #ffffff + + + + + + + + + + + + + + + + + + + + + + + diff --git a/android/src/foam/symbai/GeneaologyActivity.java b/symbaidb/src/foam/symbaidb/ReviewItemActivity.java similarity index 88% rename from android/src/foam/symbai/GeneaologyActivity.java rename to symbaidb/src/foam/symbaidb/ReviewItemActivity.java index 916e1d7e73085417ba07c42e5b7d7eb845db18be..88ad36af7dff4f4dba06ce667b4626e1c04dcb38 100644 --- a/android/src/foam/symbai/GeneaologyActivity.java +++ b/symbaidb/src/foam/symbaidb/ReviewItemActivity.java @@ -13,18 +13,18 @@ // You should have received a copy of the GNU Affero General Public License // along with this program. If not, see . -package foam.symbai; +package foam.symbaidb; import android.app.Activity; import android.os.Bundle; import android.content.Context; -public class GeneaologyActivity extends foam.starwisp.StarwispActivity +public class ReviewItemActivity extends foam.starwisp.StarwispActivity { @Override public void onCreate(Bundle savedInstanceState) { - m_Name = "geneaology"; + m_Name = "review-item"; super.onCreate(savedInstanceState); } } diff --git a/symbaidb/src/foam/symbaidb/starwisp.java b/symbaidb/src/foam/symbaidb/starwisp.java new file mode 100644 index 0000000000000000000000000000000000000000..d937484e881403d7d8e22d41930698c650764287 --- /dev/null +++ b/symbaidb/src/foam/symbaidb/starwisp.java @@ -0,0 +1,118 @@ +// Starwisp Copyright (C) 2013 Dave Griffiths +// +// This program is free software: you can redistribute it and/or modify +// it under the terms of the GNU Affero General Public License as +// published by the Free Software Foundation, either version 3 of the +// License, or (at your option) any later version. +// +// This program is distributed in the hope that it will be useful, +// but WITHOUT ANY WARRANTY; without even the implied warranty of +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +// GNU Affero General Public License for more details. +// +// You should have received a copy of the GNU Affero General Public License +// along with this program. If not, see . + +package foam.symbaidb; + +import java.util.ArrayList; + +import android.app.Activity; +import android.os.Bundle; +import android.util.Log; +import android.content.Context; +import android.graphics.Color; + +import java.io.File; +import java.io.IOException; +import java.io.BufferedReader; +import java.io.InputStreamReader; + +import android.widget.TextView; +import android.widget.Button; +import android.widget.LinearLayout; +import android.widget.SeekBar; +import android.widget.Spinner; +import android.widget.ArrayAdapter; +import android.widget.AdapterView; +import android.widget.EditText; +import android.widget.Toast; +import android.view.ViewGroup; +import android.view.ViewGroup.LayoutParams; +import android.view.WindowManager; +import android.view.View; +import android.view.Gravity; +import android.view.KeyEvent; +import android.text.TextWatcher; +import android.text.Editable; + +import org.json.JSONException; +import org.json.JSONObject; +import org.json.JSONArray; + +import java.util.Calendar; + +import foam.starwisp.StarwispActivity; +import foam.starwisp.ActivityManager; +import foam.starwisp.Scheme; +import foam.starwisp.StarwispBuilder; + +public class starwisp extends StarwispActivity +{ + static { + // register all activities here + ActivityManager.RegisterActivity("main",starwisp.class); + ActivityManager.RegisterActivity("review-item",ReviewItemActivity.class); + }; + + /** Called when the activity is first created. */ + @Override + public void onCreate(Bundle savedInstanceState) + { + setContentView(R.layout.main); + + String dirname = "symbai/"; + m_AppDir = "/sdcard/"+dirname; + File appdir = new File(m_AppDir); + appdir.mkdirs(); + + File filesdir = new File(m_AppDir+"/files/"); + filesdir.mkdirs(); + File backupdir = new File(m_AppDir+"/backup/"); + backupdir.mkdirs(); + + // build static things + m_Scheme = new Scheme(this); + + m_Scheme.Load("lib.scm"); + m_Scheme.Load("racket-fix.scm"); + m_Scheme.Load("eavdb/ktv.ss"); + m_Scheme.Load("eavdb/ktv-list.ss"); + m_Scheme.Load("eavdb/entity-values.ss"); + m_Scheme.Load("eavdb/entity-insert.ss"); + m_Scheme.Load("eavdb/entity-get.ss"); + m_Scheme.Load("eavdb/entity-update.ss"); + m_Scheme.Load("eavdb/entity-filter.ss"); + m_Scheme.Load("eavdb/entity-sync.ss"); + m_Scheme.Load("eavdb/entity-csv.ss"); + m_Scheme.Load("eavdb/eavdb.ss"); + m_Scheme.Load("dbsync.scm"); + + m_Builder = new StarwispBuilder(m_Scheme); + m_Name = "main"; + + // tell scheme the date + final Calendar c = Calendar.getInstance(); + int day = c.get(Calendar.DAY_OF_MONTH); + int month = c.get(Calendar.MONTH)+1; + int year = c.get(Calendar.YEAR); + + // pass in a bunch of useful stuff + m_Scheme.eval("(define dirname \"/sdcard/"+dirname+"\")(define date-day "+day+") (define date-month "+month+") (define date-year "+year+")"); + + Log.i("starwisp","started, now running starwisp.scm..."); + m_Scheme.eval(m_Scheme.readRawTextFile(this, "starwisp.scm")); + + super.onCreate(savedInstanceState); + } +} diff --git a/translations.csv b/translations.csv index 24271c228d77ca9df67ad4011069504f5c5c4180..90917f87f855547bd8c82cd0f25f4227423f603b 100644 --- a/translations.csv +++ b/translations.csv @@ -1,9 +1,18 @@ -"test-num",1,1,1," " -"test-text"," I am test text"," I am test text"," I am test text"," " -"one","one"," ",, -"two","two"," ",, -"three"," three"," ",, +"Code (don't change these)","English","Khasi","Hindi", +"start","Symbai",,, "next","Next",,, +"yes","Yes",,, +"no","No",,, +"not-answered","Unanswered",,, +"not-set","Not set",,, +"details-next","Next",,, +"family-next","Next",,, +"migration-next","Next",,, +"income-next","Next",,, +"gene-next","Next",,, +"social-next","Next",,, +"friendship-next","Next",,, +"agreement-next","Next",,, "village"," Village"," ",, "household"," Household"," ",, "households"," Households"," ",, @@ -30,6 +39,7 @@ "quick-add"," Quick add"," ",, "find-individual"," Find individual"," ",, "filter"," Filter"," ",, +"filter-switch","Run filter",,, "off"," Off"," Off"," Off"," " "name"," Name","Kyrteng",, "sync-all"," Sync me!"," ",, @@ -110,7 +120,7 @@ "migration-button"," Migration"," ",, "friendship-button","Friendship",,, "income-button"," Income"," ",, -"geneaology-button"," Geneaology"," ",, +"genealogy-button"," Genealogy"," ",, "social-button"," Social"," ",, "agreement-button"," Agreement"," ",, "is-a-child"," Child"," ",,