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

fixed dynamic id again, more i18n

parent ba3e0490
......@@ -112,6 +112,7 @@
(entity-add-value! "time" "varchar" (date-time->string (date-time)))
(entity-add-value! "lat" "real" (car (get-current 'location '(0 0))))
(entity-add-value! "lon" "real" (cadr (get-current 'location '(0 0))))
(entity-add-value! "deleted" "int" 0)
(let ((values (get-current 'entity-values '())))
(cond
((not (null? values))
......
......@@ -218,124 +218,13 @@
(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 "
"where entity_type = ? and n.attribute_id = ? order by n.value")
type "name")))
(msg (db-status db))
(if (null? s)
'()
(map
(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))))
" 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)
'()
......@@ -372,7 +261,6 @@
(cons ktv (cdr ktv-list)))
(else (cons (car ktv-list) (ktv-set (cdr ktv-list) ktv)))))
(define (db-all db table type)
(prof-start "db-all")
(let ((r (map
......@@ -382,63 +270,6 @@
(prof-end "db-all")
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
......
......@@ -547,15 +547,21 @@
(id-map-get name))
(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 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 '())
......@@ -744,6 +750,7 @@
((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) 'grid-buttons)
(add-callback! (callback (update-widget-id w)
......@@ -880,7 +887,10 @@
((callback-fn cb)))
(else
(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)
(send (scheme->json events))
(prof-end "widget-callback")))))
......
......@@ -72,6 +72,10 @@
(list 'ok (list "Ok" "Ok" "Ok"))
(list 'cancel (list "Cancel" "Cancel" "Cancel"))
(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
(list 'village-name (list "Village name" "Village name" "Village name"))
......@@ -262,12 +266,12 @@
(define (mtitle id)
(text-view (symbol->id 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)
(text-view (symbol->id 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)
(vert
......@@ -340,25 +344,6 @@
(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)
(define (date-minus-months d ms)
(let ((year (list-ref d 0))
......@@ -372,18 +357,6 @@
(list-ref d 4)
(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 @@
(lambda (fragment arg)
(activity-layout fragment))
(lambda (fragment arg)
(msg "updating top" (get-current 'activity-title "Title not set"))
(list
(update-widget 'text-view (get-id "title") 'text
(get-current 'activity-title "Title not set"))))
......@@ -502,7 +474,7 @@
(list
(alert-dialog
"ok-check"
"Are you sure you want to save changes?"
(mtext-lookup 'save-are-you-sure)
(lambda (v)
(cond
((eqv? v 1)
......@@ -567,20 +539,40 @@
;; pull db data into list of button widgets
(define (update-list-widget db table entity-type edit-activity)
(update-widget
'linear-layout
(get-id (string-append entity-type "-list"))
'contents
(map
(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)
(lambda ()
(msg "sending start act" (ktv-get e "unique_id"))
(list (start-activity edit-activity 0 (ktv-get e "unique_id"))))))
(db-all db table entity-type))))
(let ((search-results (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")))
(or (ktv-get e "name") "Unamed item")
40 (layout 'fill-parent 'wrap-content 1 'centre 5)
(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
......@@ -598,12 +590,13 @@
(mbutton-scale 'sync (lambda () (list))))
(mspinner 'languages (list 'english 'khasi 'hindi) (lambda (c) (list)))
(build-list-widget db "sync" "village" "village"
(list
(ktv "name" "varchar" (mtext-lookup 'default-village-name))
(ktv "block" "varchar" "")
(ktv "district" "varchar" "test")
(ktv "car" "int" 0))))
(build-list-widget
db "sync" "village" "village"
(list
(ktv "name" "varchar" (mtext-lookup 'default-village-name))
(ktv "block" "varchar" "")
(ktv "district" "varchar" "test")
(ktv "car" "int" 0))))
(lambda (activity arg)
(set-current! 'activity-title "Main screen")
......@@ -655,7 +648,8 @@
(place-widgets 'district-bus-service #f)
(place-widgets 'panchayat #t)
(place-widgets 'NGO #f)
(place-widgets 'market #t)))
(place-widgets 'market #t)
(delete-button)))
(lambda (activity arg)
(set-current! 'activity-title "Village")
(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