Commit b05cff56 authored by Dave Griffiths's avatar Dave Griffiths
Browse files

fixed dynamic id again, more i18n

parent ba3e0490
...@@ -112,6 +112,7 @@ ...@@ -112,6 +112,7 @@
(entity-add-value! "time" "varchar" (date-time->string (date-time))) (entity-add-value! "time" "varchar" (date-time->string (date-time)))
(entity-add-value! "lat" "real" (car (get-current 'location '(0 0)))) (entity-add-value! "lat" "real" (car (get-current 'location '(0 0))))
(entity-add-value! "lon" "real" (cadr (get-current 'location '(0 0)))) (entity-add-value! "lon" "real" (cadr (get-current 'location '(0 0))))
(entity-add-value! "deleted" "int" 0)
(let ((values (get-current 'entity-values '()))) (let ((values (get-current 'entity-values '())))
(cond (cond
((not (null? values)) ((not (null? values))
......
...@@ -218,124 +218,13 @@ ...@@ -218,124 +218,13 @@
(let ((s (db-select (let ((s (db-select
db (string-append "select e.entity_id from " table "_entity as e " db (string-append "select e.entity_id from " table "_entity as e "
"join " table "_value_varchar " "join " table "_value_varchar "
" as n on n.entity_id = e.entity_id " " as n on n.entity_id = e.entity_id and n.attribute_id = ?"
"where entity_type = ? and n.attribute_id = ? order by n.value") "left join " table "_value_int "
type "name"))) "as d on d.entity_id = e.entity_id and d.attribute_id = ? "
(msg (db-status db)) "where e.entity_type = ? "
(if (null? s) "and (d.value='NULL' or d.value is NULL or d.value = 0) "
'() "order by n.value")
(map "name" "deleted" type)))
(lambda (i)
(vector-ref i 0))
(cdr s)))))
(define (all-entities-where db table type ktv)
(let ((s (db-select
db (string-append
"select e.entity_id from " table "_entity as e "
"join " table "_value_" (ktv-type ktv)
" as a on a.entity_id = e.entity_id "
"join " table "_value_varchar "
" as n on n.entity_id = e.entity_id "
"where e.entity_type = ? and a.attribute_id = ? "
"and a.value = ? and n.attribute_id = ? order by n.value")
type (ktv-key ktv) (ktv-value ktv) "name")))
(msg (db-status db))
(if (null? s)
'()
(map
(lambda (i)
(vector-ref i 0))
(cdr s)))))
(define (all-entities-where2 db table type ktv ktv2)
(let ((s (db-select
db (string-append
"select e.entity_id from " table "_entity as e "
"join " table "_value_" (ktv-type ktv)
" as a on a.entity_id = e.entity_id "
"join " table "_value_" (ktv-type ktv2)
" as b on b.entity_id = e.entity_id "
"where e.entity_type = ? and a.attribute_id = ? and b.attribute_id =? and a.value = ? and b.value = ? ")
type (ktv-key ktv) (ktv-key ktv2) (ktv-value ktv) (ktv-value ktv2))))
(msg (db-status db))
(if (null? s)
'()
(map
(lambda (i)
(vector-ref i 0))
(cdr s)))))
(define (all-entities-where2or db table type ktv ktv2 or-value)
(let ((s (db-select
db (string-append
"select e.entity_id from " table "_entity as e "
"join " table "_value_" (ktv-type ktv)
" as a on a.entity_id = e.entity_id "
"join " table "_value_" (ktv-type ktv2)
" as b on b.entity_id = e.entity_id "
"where e.entity_type = ? and a.attribute_id = ? and b.attribute_id =? and a.value = ? and (b.value = ? or b.value = ?) ")
type (ktv-key ktv) (ktv-key ktv2) (ktv-value ktv) (ktv-value ktv2) or-value)))
(msg (db-status db))
(if (null? s)
'()
(map
(lambda (i)
(vector-ref i 0))
(cdr s)))))
(define (all-entities-where-newer db table type ktv ktv2)
(let ((s (db-select
db (string-append
"select e.entity_id from " table "_entity as e "
"join " table "_value_" (ktv-type ktv)
" as a on a.entity_id = e.entity_id "
"join " table "_value_" (ktv-type ktv2)
" as b on b.entity_id = e.entity_id "
"where e.entity_type = ? "
"and a.attribute_id = ? and a.value = ? "
"and b.attribute_id = ? and (b.value > DateTime(?) and b.value != ?)"
)
type (ktv-key ktv) (ktv-value ktv) (ktv-key ktv2) (ktv-value ktv2) "Unknown")))
(msg "date select" (db-status db))
(if (null? s)
'()
(map
(lambda (i)
(vector-ref i 0))
(cdr s)))))
(define (all-entities-where-older db table type ktv ktv2)
(let ((s (db-select
db (string-append
"select e.entity_id from " table "_entity as e "
"join " table "_value_" (ktv-type ktv)
" as a on a.entity_id = e.entity_id "
"join " table "_value_" (ktv-type ktv2)
" as b on b.entity_id = e.entity_id "
"where e.entity_type = ? "
"and a.attribute_id = ? and a.value = ? "
"and b.attribute_id = ? and (b.value < DateTime(?) or b.value = ?)"
)
type (ktv-key ktv) (ktv-value ktv) (ktv-key ktv2) (ktv-value ktv2) "Unknown")))
(msg "date select" (db-status db))
(if (null? s)
'()
(map
(lambda (i)
(vector-ref i 0))
(cdr s)))))
(define (update-entities-where2 db table type ktv ktv2)
(let ((s (db-select
db (string-append
"select e.entity_id from " table "_entity as e "
"join " table "_value_" (ktv-type ktv)
" as a on a.entity_id = e.entity_id "
"join " table "_value_" (ktv-type ktv2)
" as b on b.entity_id = e.entity_id "
"where e.entity_type = ? and a.attribute_id = ? and b.attribute_id =? and a.value = ? and b.value = ? ")
type (ktv-key ktv) (ktv-key ktv2) (ktv-value ktv) (ktv-value ktv2))))
(msg (db-status db)) (msg (db-status db))
(if (null? s) (if (null? s)
'() '()
...@@ -372,7 +261,6 @@ ...@@ -372,7 +261,6 @@
(cons ktv (cdr ktv-list))) (cons ktv (cdr ktv-list)))
(else (cons (car ktv-list) (ktv-set (cdr ktv-list) ktv))))) (else (cons (car ktv-list) (ktv-set (cdr ktv-list) ktv)))))
(define (db-all db table type) (define (db-all db table type)
(prof-start "db-all") (prof-start "db-all")
(let ((r (map (let ((r (map
...@@ -382,63 +270,6 @@ ...@@ -382,63 +270,6 @@
(prof-end "db-all") (prof-end "db-all")
r)) r))
;(define (db-all-where db table type clause)
; (prof-start "db-all-where")
; (let ((r (foldl
; (lambda (i r)
; (let ((e (get-entity db table i)))
; (if (equal? (ktv-get e (car clause)) (cadr clause))
; (cons e r) r)))
; '()
; (all-entities db table type))))
; (prof-end "db-all-where")
; r))
(define (db-all-where db table type ktv)
(prof-start "db-all-where")
(let ((r (map
(lambda (i)
(get-entity db table i))
(all-entities-where db table type ktv))))
(prof-end "db-all-where")
r))
(define (db-all-where2 db table type ktv ktv2)
(prof-start "db-all-where2")
(let ((r (map
(lambda (i)
(get-entity db table i))
(all-entities-where2 db table type ktv ktv2))))
(prof-end "db-all-where2")
r))
(define (db-all-where2or db table type ktv ktv2 or-value)
(prof-start "db-all-where2or")
(let ((r (map
(lambda (i)
(get-entity db table i))
(all-entities-where2or db table type ktv ktv2 or-value))))
(prof-end "db-all-where2or")
r))
(define (db-all-newer db table type ktv ktv2)
(prof-start "db-all-where newer")
(let ((r (map
(lambda (i)
(get-entity db table i))
(all-entities-where-newer db table type ktv ktv2))))
(prof-end "db-all-where newer")
r))
(define (db-all-older db table type ktv ktv2)
(prof-start "db-all-where older")
(let ((r (map
(lambda (i)
(get-entity db table i))
(all-entities-where-older db table type ktv ktv2))))
(prof-end "db-all-where older")
r))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; updating data ;; updating data
......
...@@ -547,15 +547,21 @@ ...@@ -547,15 +547,21 @@
(id-map-get name)) (id-map-get name))
(define (make-id name) (define (make-id name)
(msg "making id for" name)
(let ((id (id-map-get name))) (let ((id (id-map-get name)))
(cond (cond
((zero? id) ((zero? id)
(msg "this is a new id")
; (prof-start "make-id") ; (prof-start "make-id")
(id-map-add name current-id) (id-map-add name current-id)
(set! current-id (+ current-id 1)) (set! current-id (+ current-id 1))
; (prof-end "make-id") ; (prof-end "make-id")
(- current-id 1)) (- current-id 1))
(else id)))) (else
;; seems scheme is shut down while the id store keeps going?
(when (> id current-id) (set! current-id (+ id 1)))
(msg "we have seen this one before")
id))))
(define prof-map '()) (define prof-map '())
...@@ -744,6 +750,7 @@ ...@@ -744,6 +750,7 @@
((null? w) #f) ((null? w) #f)
;; drill deeper ;; drill deeper
((eq? (update-widget-token w) 'contents) ((eq? (update-widget-token w) 'contents)
(msg "updateing contents from callback")
(update-callbacks! (update-widget-value w))) (update-callbacks! (update-widget-value w)))
((eq? (update-widget-token w) 'grid-buttons) ((eq? (update-widget-token w) 'grid-buttons)
(add-callback! (callback (update-widget-id w) (add-callback! (callback (update-widget-id w)
...@@ -880,7 +887,10 @@ ...@@ -880,7 +887,10 @@
((callback-fn cb))) ((callback-fn cb)))
(else (else
(msg "no callbacks for type" (callback-type cb)))))) (msg "no callbacks for type" (callback-type cb))))))
;;(update-callbacks! events) ;; this was just update-callbacks, commented out,
;; expecting trouble here... (but seems to fix new widgets from
;; widget callbacks so far)
(update-callbacks-from-update! events)
(update-dialogs! events) (update-dialogs! events)
(send (scheme->json events)) (send (scheme->json events))
(prof-end "widget-callback"))))) (prof-end "widget-callback")))))
......
...@@ -72,6 +72,10 @@ ...@@ -72,6 +72,10 @@
(list 'ok (list "Ok" "Ok" "Ok")) (list 'ok (list "Ok" "Ok" "Ok"))
(list 'cancel (list "Cancel" "Cancel" "Cancel")) (list 'cancel (list "Cancel" "Cancel" "Cancel"))
(list 'villages (list "Villages" "Villages" "Villages")) (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?"))
;; village screen ;; village screen
(list 'village-name (list "Village name" "Village name" "Village name")) (list 'village-name (list "Village name" "Village name" "Village name"))
...@@ -262,12 +266,12 @@ ...@@ -262,12 +266,12 @@
(define (mtitle id) (define (mtitle id)
(text-view (symbol->id id) (text-view (symbol->id id)
(mtext-lookup id) (mtext-lookup id)
50 (layout 'fill-parent 'wrap-content -1 'centre 0))) 50 (layout 'fill-parent 'wrap-content -1 'centre 5)))
(define (mtitle-scale id) (define (mtitle-scale id)
(text-view (symbol->id id) (text-view (symbol->id id)
(mtext-lookup id) (mtext-lookup id)
50 (layout 'fill-parent 'wrap-content 1 'centre 0))) 50 (layout 'fill-parent 'wrap-content 1 'centre 5)))
(define (medit-text id type fn) (define (medit-text id type fn)
(vert (vert
...@@ -340,25 +344,6 @@ ...@@ -340,25 +344,6 @@
(else (msg "mupdate-widget unhandled widget type" widget-type)))) (else (msg "mupdate-widget unhandled widget type" widget-type))))
;;;; ;;;;
(define (db-mongooses-by-pack)
(db-all-where
db "sync" "mongoose"
(ktv "pack-id" "varchar" (ktv-get (get-current 'pack '()) "unique_id"))))
(define (db-mongooses-by-pack-male)
(db-all-where2or
db "sync" "mongoose"
(ktv "pack-id" "varchar" (ktv-get (get-current 'pack '()) "unique_id"))
(ktv "gender" "varchar" "Male") "Unknown"))
(define (db-mongooses-by-pack-female)
(db-all-where2or
db "sync" "mongoose"
(ktv "pack-id" "varchar" (ktv-get (get-current 'pack '()) "unique_id"))
(ktv "gender" "varchar" "Female") "Unknown"))
;; (y m d h m s) ;; (y m d h m s)
(define (date-minus-months d ms) (define (date-minus-months d ms)
(let ((year (list-ref d 0)) (let ((year (list-ref d 0))
...@@ -372,18 +357,6 @@ ...@@ -372,18 +357,6 @@
(list-ref d 4) (list-ref d 4)
(list-ref d 5))))) (list-ref d 5)))))
(define (db-mongooses-by-pack-pups)
(db-all-newer
db "sync" "mongoose"
(ktv "pack-id" "varchar" (ktv-get (get-current 'pack '()) "unique_id"))
(ktv "dob" "varchar" (date->string (date-minus-months (date-time) 6)))))
(define (db-mongooses-by-pack-adults)
(db-all-older
db "sync" "mongoose"
(ktv "pack-id" "varchar" (ktv-get (get-current 'pack '()) "unique_id"))
(ktv "dob" "varchar" (date->string (date-minus-months (date-time) 6)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
...@@ -479,7 +452,6 @@ ...@@ -479,7 +452,6 @@
(lambda (fragment arg) (lambda (fragment arg)
(activity-layout fragment)) (activity-layout fragment))
(lambda (fragment arg) (lambda (fragment arg)
(msg "updating top" (get-current 'activity-title "Title not set"))
(list (list
(update-widget 'text-view (get-id "title") 'text (update-widget 'text-view (get-id "title") 'text
(get-current 'activity-title "Title not set")))) (get-current 'activity-title "Title not set"))))
...@@ -502,7 +474,7 @@ ...@@ -502,7 +474,7 @@
(list (list
(alert-dialog (alert-dialog
"ok-check" "ok-check"
"Are you sure you want to save changes?" (mtext-lookup 'save-are-you-sure)
(lambda (v) (lambda (v)
(cond (cond
((eqv? v 1) ((eqv? v 1)
...@@ -567,20 +539,40 @@ ...@@ -567,20 +539,40 @@
;; pull db data into list of button widgets ;; pull db data into list of button widgets
(define (update-list-widget db table entity-type edit-activity) (define (update-list-widget db table entity-type edit-activity)
(update-widget (let ((search-results (db-all db table entity-type)))
'linear-layout (update-widget
(get-id (string-append entity-type "-list")) 'linear-layout
'contents (get-id (string-append entity-type "-list"))
(map 'contents
(lambda (e) (if (null? search-results)
(button (list (mtext 'list-empty))
(make-id (string-append "list-button-" (ktv-get e "unique_id"))) (map
(or (ktv-get e "name") "Unamed item") (lambda (e)
40 (layout 'fill-parent 'wrap-content 1 'centre 5) (button
(lambda () (make-id (string-append "list-button-" (ktv-get e "unique_id")))
(msg "sending start act" (ktv-get e "unique_id")) (or (ktv-get e "name") "Unamed item")
(list (start-activity edit-activity 0 (ktv-get e "unique_id")))))) 40 (layout 'fill-parent 'wrap-content 1 'centre 5)
(db-all db table entity-type)))) (lambda ()
(msg "sending start act" (ktv-get e "unique_id"))
(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)))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; activities ;; activities
...@@ -598,12 +590,13 @@ ...@@ -598,12 +590,13 @@
(mbutton-scale 'sync (lambda () (list)))) (mbutton-scale 'sync (lambda () (list))))
(mspinner 'languages (list 'english 'khasi 'hindi) (lambda (c) (list))) (mspinner 'languages (list 'english 'khasi 'hindi) (lambda (c) (list)))
(build-list-widget db "sync" "village" "village" (build-list-widget
(list db "sync" "village" "village"
(ktv "name" "varchar" (mtext-lookup 'default-village-name)) (list
(ktv "block" "varchar" "") (ktv "name" "varchar" (mtext-lookup 'default-village-name))
(ktv "district" "varchar" "test") (ktv "block" "varchar" "")
(ktv "car" "int" 0)))) (ktv "district" "varchar" "test")
(ktv "car" "int" 0))))
(lambda (activity arg) (lambda (activity arg)
(set-current! 'activity-title "Main screen") (set-current! 'activity-title "Main screen")
...@@ -655,7 +648,8 @@ ...@@ -655,7 +648,8 @@
(place-widgets 'district-bus-service #f) (place-widgets 'district-bus-service #f)
(place-widgets 'panchayat #t) (place-widgets 'panchayat #t)
(place-widgets 'NGO #f) (place-widgets 'NGO #f)
(place-widgets 'market #t))) (place-widgets 'market #t)
(delete-button)))
(lambda (activity arg) (lambda (activity arg)
(set-current! 'activity-title "Village") (set-current! 'activity-title "Village")
(activity-layout activity)) (activity-layout activity))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment