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

half added social screen

parent fb4b99fd
...@@ -91,7 +91,6 @@ ...@@ -91,7 +91,6 @@
;; version to check the entity has the key ;; version to check the entity has the key
(define (entity-set-value! key type value) (define (entity-set-value! key type value)
(msg "entity-set-value!")
(let ((existing-type (ktv-get-type (get-current 'entity-values '()) key))) (let ((existing-type (ktv-get-type (get-current 'entity-values '()) key)))
(if (equal? existing-type type) (if (equal? existing-type type)
(set-current! (set-current!
...@@ -102,8 +101,7 @@ ...@@ -102,8 +101,7 @@
;; ;;
(begin (begin
(msg "entity-set-value! - adding new " key "of type" type "to entity") (msg "entity-set-value! - adding new " key "of type" type "to entity")
(entity-add-value-create! key type value))) (entity-add-value-create! key type value)))))
(msg "done entity-set-value!")))
(define (date-time->string dt) (define (date-time->string dt)
...@@ -528,6 +526,25 @@ ...@@ -528,6 +526,25 @@
(layout 'fill-parent 'wrap-content 1 'centre 0) (layout 'fill-parent 'wrap-content 1 'centre 0)
(lambda (t) (fn t)))))) (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) (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) (define (mclear-toggles id-list)
(map (map
...@@ -559,7 +576,6 @@ ...@@ -559,7 +576,6 @@
(entity-get-value key))) (entity-get-value key)))
((eq? widget-type 'image-view) ((eq? widget-type 'image-view)
(let ((image-name (entity-get-value key))) (let ((image-name (entity-get-value key)))
(msg "updating image widget to: " image-name)
(if (image-invalid? image-name) (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) 'image "face")
(update-widget widget-type (get-symbol-id id-symbol) 'external-image (update-widget widget-type (get-symbol-id id-symbol) 'external-image
......
...@@ -261,18 +261,20 @@ ...@@ -261,18 +261,20 @@
;; get an entire entity, as a list of key/value pairs ;; get an entire entity, as a list of key/value pairs
(define (get-entity-plain db table entity-id) (define (get-entity-plain db table entity-id)
(msg "get-entity-plain")
(let* ((entity-type (get-entity-type db table entity-id))) (let* ((entity-type (get-entity-type db table entity-id)))
(cond (cond
((null? entity-type) (msg "entity" entity-id "not found!") '()) ((null? entity-type) (msg "entity" entity-id "not found!") '())
(else (else
(map (foldl
(lambda (kt) (lambda (kt r)
(let ((vdv (get-value db table entity-id kt))) (let ((vdv (get-value db table entity-id kt)))
(if (null? vdv) (if (null? vdv)
(msg "ERROR: get-entity-plain: no value found for " entity-id " " (ktv-key kt)) (begin
(list (ktv-key kt) (ktv-type kt) (msg "ERROR: get-entity-plain: no value found for " entity-id " " (ktv-key kt))
(list-ref vdv 0) (list-ref vdv 2))))) 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-attribute-ids/types db table entity-type))))))
;; get an entire entity, as a list of key/value pairs, only dirty values ;; get an entire entity, as a list of key/value pairs, only dirty values
......
...@@ -47,6 +47,10 @@ ...@@ -47,6 +47,10 @@
(define education-list '(illiterate literate primary middle high secondary university)) (define education-list '(illiterate literate primary middle high secondary university))
(define married-list '(ever-married currently-married currently-single seperated)) (define married-list '(ever-married currently-married currently-single seperated))
(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))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; user interface abstraction ;; user interface abstraction
...@@ -182,7 +186,7 @@ ...@@ -182,7 +186,7 @@
;; family ;; family
(list 'spouse (list "Spouse")) (list 'spouse (list "Spouse"))
(list 'change-id (list "Update ID")) (list 'change-id (list "Change"))
(list 'head-of-house (list "Head of house")) (list 'head-of-house (list "Head of house"))
(list 'marital-status (list "Marital status")) (list 'marital-status (list "Marital status"))
(list 'ever-married (list "Ever married")) (list 'ever-married (list "Ever married"))
...@@ -242,13 +246,41 @@ ...@@ -242,13 +246,41 @@
(list 'town-sell (list "Town or city visits")) (list 'town-sell (list "Town or city visits"))
;; geneaology ;; geneaology
(list 'mother (list "Mother")) (list 'mother (list "Mother"))
(list 'father (list "Father")) (list 'father (list "Father"))
(list 'change-mother (list "Change mother")) (list 'change-mother (list "Change mother"))
(list 'change-father (list "Change father")) (list 'change-father (list "Change father"))
(list 'alive (list "Alive")) (list 'alive (list "Alive"))
(list 'sex (list "Sex")) (list 'sex (list "Sex"))
;; social
(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-relationship (list "Relationship"))
(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"))
)) ))
(define individual-ktvlist (define individual-ktvlist
...@@ -531,6 +563,20 @@ ...@@ -531,6 +563,20 @@
(filter-set! filter) (filter-set! filter)
(list (start-activity "individual-chooser" request-code "")))))) (list (start-activity "individual-chooser" request-code ""))))))
(define (build-small-person-selector id key filter request-code)
(vert
(mtitle id)
(image-view (make-id (string-append (symbol->string id) "-image"))
"face" (layout 120 160 -1 'centre 0))
(button
(make-id (string-append "change-" (symbol->string id)))
(mtext-lookup 'change-id)
40 (layout 'fill-parent 'wrap-content -1 'centre 5)
(lambda ()
(filter-set! filter)
(list (start-activity "individual-chooser" request-code ""))))))
;; from activity on result with request id: choose-code ;; from activity on result with request id: choose-code
;; todo determine *which* selector this came from... ;; todo determine *which* selector this came from...
(define (person-selector-return request-code key choose-code) (define (person-selector-return request-code key choose-code)
...@@ -549,6 +595,54 @@ ...@@ -549,6 +595,54 @@
(update-widget 'image-view id 'image "face") (update-widget 'image-view id 'image "face")
(update-widget 'image-view id 'external-image (string-append dirname "files/" image-name)))))) (update-widget 'image-view id 'external-image (string-append dirname "files/" image-name))))))
(define (build-social-connection id key type request-code)
(let ((id-text (string-append (symbol->string id))))
(horiz
(build-small-person-selector id key (list) request-code)
(mspinner-other-vert
(string->symbol (string-append id-text "-relationship"))
'social-relationship
social-relationship-list
(lambda (v)
(entity-set-value! (string-append key "-relationship") "varchar" v) '()))
(mspinner-other-vert
(string->symbol (string-append id-text "-residence"))
'social-residence
social-residence-list
(lambda (v)
(entity-set-value! (string-append key "-residence") "varchar" v) '()))
(vert
(text-view 0 (mtext-lookup 'social-strength)
30 (layout 'wrap-content 'wrap-content 1 'centre 10))
(spinner
(make-id (dbg (string-append id-text "-strength")))
(map mtext-lookup social-strength-list)
(layout 'wrap-content 'wrap-content 1 'centre 0)
(lambda (v)
(entity-set-value! (string-append key "-strength") "varchar" v) '()))))))
(define (social-connection-return request-code key choose-code)
(when (eqv? request-code choose-code)
(entity-set-value! key "varchar" (get-current 'choose-result "not set"))))
(define (update-social-connection db table id key type request-code)
(let ((id-text (string-append (symbol->string id))))
(list
;;(update-person-selector db table id key)
(mupdate-spinner-other
(string->symbol (string-append id-text "-relationship"))
(string-append key "-relationship")
social-relationship-list)
; (mupdate-spinner-other
; (string->symbol (string-append id-text "-residence"))
; (string-append key "-residence")
; social-residence-list)
; (mupdate-spinner
; (string->symbol (dbg (string-append id-text "-strength")))
; (string-append key "-strength")
; social-strength-list)
)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; activities ;; activities
...@@ -558,6 +652,12 @@ ...@@ -558,6 +652,12 @@
(define mother-request-code 996) (define mother-request-code 996)
(define father-request-code 995) (define father-request-code 995)
(define social-request-code-one 994)
(define social-request-code-two 993)
(define social-request-code-three 992)
(define social-request-code-four 991)
(define social-request-code-five 990)
(define-activity-list (define-activity-list
(activity (activity
...@@ -1013,16 +1113,33 @@ ...@@ -1013,16 +1113,33 @@
(activity (activity
"social" "social"
(build-activity (build-activity
(build-social-connection 'social-one "social-one" "friend" social-request-code-one)
(build-social-connection 'social-two "social-two" "friend" social-request-code-two)
(build-social-connection 'social-three "social-three" "friend" social-request-code-three)
(build-social-connection 'social-four "social-four" "friend" social-request-code-four)
(build-social-connection 'social-five "social-five" "friend" social-request-code-five)
) )
(lambda (activity arg) (lambda (activity arg)
(set-current! 'activity-title "Individual social network") (set-current! 'activity-title "Individual social network")
(activity-layout activity)) (activity-layout activity))
(lambda (activity arg) '()) (lambda (activity arg)
(append
(update-social-connection db "sync" 'social-one "social-one" "friend" social-request-code-one)
(update-social-connection db "sync" 'social-two "social-two" "friend" social-request-code-two)
(update-social-connection db "sync" 'social-three "social-three" "friend" social-request-code-three)
(update-social-connection db "sync" 'social-four "social-four" "friend" social-request-code-four)
(update-social-connection db "sync" 'social-five "social-five" "friend" social-request-code-five)))
(lambda (activity) '()) (lambda (activity) '())
(lambda (activity) '()) (lambda (activity) '())
(lambda (activity) '()) (lambda (activity) '())
(lambda (activity) '()) (lambda (activity) '())
(lambda (activity requestcode resultcode) '())) (lambda (activity requestcode resultcode)
(social-connection-return requestcode "social-one" social-request-code-one)
(social-connection-return requestcode "social-two" social-request-code-two)
(social-connection-return requestcode "social-three" social-request-code-three)
(social-connection-return requestcode "social-four" social-request-code-four)
(social-connection-return requestcode "social-five" social-request-code-five)
'()))
(activity (activity
"agreement" "agreement"
...@@ -1036,7 +1153,8 @@ ...@@ -1036,7 +1153,8 @@
(lambda (activity) '()) (lambda (activity) '())
(lambda (activity) '()) (lambda (activity) '())
(lambda (activity) '()) (lambda (activity) '())
(lambda (activity requestcode resultcode) '())) (lambda (activity requestcode resultcode)
'()))
(activity (activity
"individual-chooser" "individual-chooser"
......
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