Skip to content

GitLab

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

added custom programmatic filtering ORM hack

parent a01cb026
Hide whitespace changes
Inline Side-by-side
Showing with 150 additions and 81 deletions
android/assets/dbsync.scm
View file @ ad856dbd
......@@ -604,3 +604,67 @@
'text-view (get-id (string-append (symbol->string display-id) "-lon"))
'text (number->string
(entity-get-value (string-append key-prepend "-lon")) "real" 0))))
;; 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)
(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-init! db table entity-type ktv-default)
(entity-add-value! "parent" "varchar" (parent-fn))
(entity-record-values!)
(list (update-list-widget db table 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))))
;; pull db data into list of button widgets
(define (update-list-widget db table entity-type edit-activity parent)
(let ((search-results
(if parent
(db-with-parent db table entity-type parent)
(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-add-value! "deleted" "int" 1)
(entity-update-values!)
(list (finish-activity 1)))
(else
(list)))))))))
android/assets/eavdb.scm
View file @ ad856dbd
......@@ -256,6 +256,62 @@
(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 (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)
"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))))))
(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
......@@ -297,6 +353,11 @@
(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)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; updating data
......
android/assets/starwisp.scm
View file @ ad856dbd
......@@ -401,70 +401,6 @@
(spacer 5)
(build-fragment "bottom" (make-id "bottom") fillwrap)))))
;; 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)
(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-init! db table entity-type ktv-default)
(entity-add-value! "parent" "varchar" (parent-fn))
(entity-record-values!)
(list (update-list-widget db table 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))))
;; pull db data into list of button widgets
(define (update-list-widget db table entity-type edit-activity parent)
(let ((search-results
(if parent
(db-with-parent db table entity-type parent)
(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-add-value! "deleted" "int" 1)
(entity-update-values!)
(list (finish-activity 1)))
(else
(list)))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; activities
......@@ -481,21 +417,7 @@
(mbutton-scale 'sync (lambda () (list (start-activity "sync" 0 "")))))
(mspinner 'languages (list 'english 'khasi 'hindi) (lambda (c) (list)))
(mbutton 'test-upload (lambda ()
(list
(network-connect
"network"
"mongoose-web"
(lambda (state)
(msg state)
(if (equal? state "Connected")
(list
(http-upload
"test-upload"
"http://192.168.2.1:8889/symbai?fn=upload"
"/sdcard/symbai/photo.jpg"))
'()))
))))
(mbutton 'find-individual (lambda () (list (start-activity "individual-chooser" 0 ""))))
(build-list-widget
db "sync" 'villages "village" "village" (lambda () #f)
(list
......@@ -639,7 +561,7 @@
(ktv "tribe" "varchar" "none")
(ktv "subtribe" "varchar" "none")
(ktv "age" "int" 0)
(ktv "gender" "varchar" "female")
(ktv "gender" "varchar" "Female")
(ktv "education" "varchar" "none")
(ktv "head-of-house" "varchar" "none")
(ktv "marital-status" "varchar" "none")
......@@ -700,7 +622,9 @@
(image-view (make-id "photo") "face" (layout 240 320 -1 'centre 10))
(vert
(mtext 'name-display)
(spacer 20)
(mtext 'family-display)
(spacer 20)
(mtext 'photo-id-display)))
(mbutton 'agreement-button (lambda () (list (start-activity "agreement" 0 ""))))
(horiz
......@@ -977,11 +901,31 @@
(activity
"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))
(mtext 'filter-stuff))
)
(lambda (activity arg)
(set-current! 'activity-title "Individual chooser")
(activity-layout activity))
(lambda (activity arg) '())
(lambda (activity arg)
(list
(update-widget
'linear-layout (get-id "choose-pics") 'contents
(map
(lambda (e)
(msg (ktv-get e "gender"))
(let ((gender (ktv-get e "gender")))
(text-view
(make-id (string-append "chooser-" (ktv-get e "unique_id")))
(string-append (ktv-get e "unique_id") ": " (if (null? gender) "not set" gender))
30 (layout 'wrap-content 'wrap-content 1 'centre 5))))
(db-filter db "sync" "individual"
(list (make-filter "gender" "varchar" "=" "female")))))))
(lambda (activity) '())
(lambda (activity) '())
(lambda (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