starwisp.scm

;; 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 <http://www.gnu.org/licenses/>.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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)
(setup db "local")
(setup db "sync")
(setup db "stream")

(define settings-entity-id-version 2)

(insert-entity-if-not-exists
 db "local" "app-settings" "null" settings-entity-id-version
 (list
  (ktv "user-id" "varchar" "not set")
  (ktv "language" "int" 0)
  (ktv "current-village" "varchar" "none")))

(define (get-setting-value name)
  (ktv-get (get-entity db "local" settings-entity-id-version) name))

(define (set-setting! key type value)
  (update-entity
   db "local" settings-entity-id-version (list (ktv key type value))))

(define (get/inc-setting key)
  (let ((r (get-setting-value key)))
    (set-setting! key "int" (+ r 1))
    r))

(set-current! 'user-id (get-setting-value "user-id"))
(set! i18n-lang (get-setting-value "language"))

;;(display (db-all db "local" "app-settings"))(newline)

(define tribes-list '(not-set khasi other no-answered))
(define subtribe-list '(not-set khynriam pnar bhoi war other not-answered))
(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 other not-answered))

(define yesno-list '(not-set yes no not-answered))
(define social-types-list '(knowledge prestige))
(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 other not-answered))
(define social-residence-list '(not-set same other not-answered))
(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" "")
   (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?
   (ktv "house-lon" "real" 0)
   (ktv "toilet-lat" "real" 0)
   (ktv "toilet-lon" "real" 0)))

(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 "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" "not-set")
   (ktv "times-married" "int" -1)
   (ktv "id-spouse" "varchar" "")
   (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" -1)
   (ktv "birth-order" "int" -1)
   (ktv "length-time" "int" -1)
   (ktv "place-of-birth" "varchar" "")
   (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" "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-two" "varchar" "")
   (ktv "social-two-nickname" "varchar" "")
   (ktv "social-two-relationship" "varchar" "")
   (ktv "social-two-residence" "varchar" "")
   (ktv "social-two-strength" "varchar" "")
   (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-four" "varchar" "")
   (ktv "social-four-nickname" "varchar" "")
   (ktv "social-four-relationship" "varchar" "")
   (ktv "social-four-residence" "varchar" "")
   (ktv "social-four-strength" "varchar" "")
   (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 "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-two" "varchar" "")
   (ktv "friendship-two-nickname" "varchar" "")
   (ktv "friendship-two-relationship" "varchar" "")
   (ktv "friendship-two-residence" "varchar" "")
   (ktv "friendship-two-strength" "varchar" "")
   (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-four" "varchar" "")
   (ktv "friendship-four-nickname" "varchar" "")
   (ktv "friendship-four-relationship" "varchar" "")
   (ktv "friendship-four-residence" "varchar" "")
   (ktv "friendship-four-strength" "varchar" "")
   (ktv "friendship-five" "varchar" "")
   (ktv "friendship-five-nickname" "varchar" "")
   (ktv "friendship-five-relationship" "varchar" "")
   (ktv "friendship-five-residence" "varchar" "")
   (ktv "friendship-five-strength" "varchar" "")
   ))

(define crop-ktvlist
  (list
   (ktv "name" "varchar" (mtext-lookup 'default-crop-name))
   (ktv "notes" "varchar" "")
   (ktv "unit" "varchar" "unit")
   (ktv "used" "real" -1)
   (ktv "sold" "real" -1)
   (ktv "seed" "varchar" "")))

(define child-ktvlist
  (list
   (ktv "name" "varchar" (mtext-lookup 'default-child-name))
   (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")))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;

(define (debug! txt)
  (set-current! 'debug-text (string-append txt "\n" (get-current 'debug-text ""))))

(define (update-debug)
  (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))
     (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 "Syncing"))
         (upload-dirty db)
         ;; important - don't receive until all are sent...
         (if (have-dirty? db "sync") '()
             (append
              (suck-new db "sync")
              (start-sync-files)))))))
    (else '()))
   (list
    (delayed "debug-timer" (+ 10000 (random 5000)) debug-timer-cb)
    (update-debug))))

(define pf-length 20) ;; minutes...

(define (timer-cb)
  (set-current!
   'timer-seconds
   (- (get-current 'timer-seconds 59) 1))
  (append
   (cond
    ((< (get-current 'timer-seconds 59) 0)

     (set-current! 'timer-minutes (- (get-current 'timer-minutes pf-length) 1))
     (set-current! 'timer-seconds 59)
     (cond ((< (get-current 'timer-minutes pf-length) 1)
            (list
             (alert-dialog
              "pup-focal-end"
              "Pup focal time is up, have you finished?"
              (lambda (v)
                (cond
                 ((eqv? v 1)
                  (list (finish-activity 1)))
                 (else
                  (set-current! 'timer-minutes 1)
                  (list)))))))
           (else
            (list (replace-fragment (get-id "pf-top") "pf-scan1")))))
    (else '()))
   (list
    (delayed "timer" 1000 timer-cb)
    (update-widget
     'text-view (get-id "pf-timer-time-minutes") 'text
     (string-append (number->string (get-current 'timer-minutes pf-length))))
    (update-widget
     'text-view (get-id "pf-timer-time") 'text
     (string-append (number->string (get-current 'timer-seconds 59))))
    )))


(define (force-pause)
  (list
   (delayed "timer" 1000 (lambda () '()))
   (update-widget 'toggle-button (get-id "pf-pause") 'checked 1)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; fragments


(define-fragment-list

  (fragment
   "top"
   (horiz
    (image-button (make-id "top-icon") "logo" (layout 48 64 -1 'centre 0)
                  (lambda () (list (start-activity-goto "main2" 0 ""))))
    (text-view (make-id "title") "" 30
               (layout 'fill-parent 'fill-parent 0.5 'centre 10))

    (linear-layout
     0 'vertical
     (layout 'fill-parent 'wrap-content 0.5 'centre 0)
     (list 0 0 0 0)

     (list
      (text-view (make-id "top-village") 'name 20
                 (layout 'wrap-content 'wrap-content 1 'right 0))
      (text-view (make-id "top-household") 'name 20
                 (layout 'wrap-content 'wrap-content 1 'right 0))
      (text-view (make-id "top-photo-id") 'photo-id 20
                 (layout 'wrap-content 'wrap-content 1 'right 0)))))
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


  (fragment
   "bottom"
   (linear-layout
    0 'horizontal
    (layout 'fill-parent 'fill-parent 1 'centre 0)
    (list 0 0 0 0)
    (list
;     (mbutton-scale
;      'save
;      (lambda ()
;        (list
;         (alert-dialog
;          "ok-check"
;          (mtext-lookup 'save-are-you-sure)
;          (lambda (v)
;            (cond
;             ((eqv? v 1)
;              (entity-update-values!)
;              (list))
;             (else
;              (list))))))))
     (mbutton-scale 'back (lambda () (list (finish-activity 1))))))
   (lambda (fragment arg)
     (activity-layout fragment))
   (lambda (fragment arg)
     (list))
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '())
   (lambda (fragment) '()))


  )

(define (update-top-bar)
  (let ((village (get-entity-name db "sync" (get-current 'village #f)))
        (household (get-entity-name db "sync" (get-current 'household #f)))
        (individual (get-entity-name db "sync" (get-current 'individual #f))))
    (list
     (update-widget 'text-view (get-id "title") 'text
                    (get-current 'activity-title "Title not set"))
     (update-widget 'text-view (get-id "top-village") 'text (if village (string-append "Village: " village) ""))
     (update-widget 'text-view (get-id "top-household") 'text (if household (string-append "Household: " household) ""))
     (update-widget 'text-view (get-id "top-photo-id") 'text (if individual (string-append "Individual: " individual) "")))))



(define (build-activity . contents)
  (vert-fill
   (relative
    '(("parent-top"))
    colour-one ;;(list 100 100 255 127)
    (build-fragment "top" (make-id "top") fillwrap))

   (scroll-view-vert
    0 (layout 'fill-parent 'fill-parent 1 'centre 0)
    (list
     (apply vert-fill contents)))

   (relative
    '(("parent-bottom"))
    colour-one
    (vert
     (spacer 5)
     (build-fragment "bottom" (make-id "bottom") fillwrap)))))


(define (grid-ify widgets n)
  (map
   (lambda (w)
     (linear-layout
      0 'horizontal
      (layout 'wrap-content 'wrap-content 1 'left 0)
      (list 0 0 0 0)
      w))
   (chop widgets n)))

(define (filter-set! l)
  (set-current! 'individual-filter l))

(define (filter-clear!)
  (filter-set! '()))

(define (filter-add! f)
  (set-current!
   'individual-filter
   (merge-filter f (get-current 'individual-filter '()))))

(define (filter-remove! key)
  (set-current!
   'individual-filter
   (delete-filter key (get-current 'individual-filter '()))))

(define (filter-get)
  (get-current 'individual-filter '()))

(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
   (map
    (lambda (e)
      (let* ((id (ktv-get e "unique_id"))
             (image-name (ktv-get e "photo"))
             (image (if (image-invalid? image-name)
                        "face" (string-append "/sdcard/symbai/files/" image-name))))
        (cond
         ((> (length search) 500)
          (button
           (make-id (string-append "chooser-" id))
           (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)))))

         ((equal? image "face")
          (button
           (make-id (string-append "chooser-" id))
           (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)))))

         (else
          (vert
           (image-button
            (make-id (string-append "chooser-" id))
            image (layout (car button-size) (cadr button-size) 1 'centre 5)
            (lambda ()
              (set-current! 'choose-result id)
              (list (finish-activity 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)
  (set! filter-households households)
  (set! filter-index 0)
  (delayed "filter-delayed" 100 gradual-build))

(define (update-individual-filter)
  (let ((households (db-filter-only db "sync" "household"
                                    (list (list "parent" "varchar" "=" (get-setting-value "current-village")))
                                    (list (list "name" "varchar")))))
    (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
     (build-photo-buttons search))
    ))



(define (image/name-from-unique-id db table unique-id)
  (let ((e (get-entity-by-unique db table unique-id)))
    (list
     (ktv-get e "name")
     (ktv-get e "photo"))))

(define (build-person-selector id key filter request-code)
  (vert
   (mtitle id)
   (image-view (make-id (string-append (symbol->string id) "-image"))
               "face" (layout 240 320 -1 'centre 0))
   (mtext-small (string->symbol (string-append (symbol->string id) "-text")))
   (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 ""))))))

(define (build-small-person-selector id key filter request-code)
  (linear-layout
   0 'vertical
   (layout 300 'wrap-content 1 'centre 10)
   (list 0 0 0 0)
   (list
    (mtitle id)
    (image-view (make-id (string-append (symbol->string id) "-image"))
                "face" (layout 120 160 -1 'centre 0))
    (mtext-small (string->symbol (string-append (symbol->string id) "-text")))
    (button
     (make-id (string-append "change-" (symbol->string id)))
     (mtext-lookup 'change-id)
     40 (layout 'wrap-content '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
;; todo determine *which* selector this came from...
(define (person-selector-return request-code key 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!)))

;; need to load from across entities, so need db, table
(define (update-person-selector db table id key)
  (let ((entity-id (entity-get-value key)))
    (let ((image-name (image/name-from-unique-id db table entity-id))
          (id (get-id (string-append (symbol->string id) "-image")))
          (text-id (get-id (string-append (symbol->string id) "-text"))))
      (if (image-invalid? (cadr image-name))
          (list
           (update-widget 'image-view id 'image "face")
           (update-widget 'text-view text-id 'text (or (car image-name) "")))
          (list
           (update-widget 'text-view text-id 'text (or (car image-name) ""))
           (update-widget 'image-view id 'external-image
                          (string-append dirname "files/" (cadr image-name))))))))

(define (build-social-connection id key type request-code shade)
  (let ((id-text (string-append (symbol->string id))))
    (linear-layout
     0 'horizontal
     (layout 'wrap-content 'wrap-content 1 'centre 20)
     (if shade colour-one colour-two)
     (list
      (build-small-person-selector id key (list) request-code)
      (vert
       (horiz
        (linear-layout
         0 'vertical (layout 'fill-parent 'wrap-content 1 'centre 20) (list 0 0 0 0)
         (list
          (text-view 0 (mtext-lookup 'social-nickname)
                     30 (layout 'wrap-content 'wrap-content 1 'centre 0))
          (edit-text (make-id (string-append id-text "-nickname")) "" 30 "normal"
                     (layout 'fill-parent 'wrap-content 1 'centre 0)
                     (lambda (v)
                       (entity-set-value! (string-append key "-nickname") "varchar" v)
                       '()))))

        (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"
                              (spinner-choice social-relationship-list v))
           '())))

       (horiz
        (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"
                              (spinner-choice social-residence-list v)) '()))
        (vert
         (text-view 0 (mtext-lookup 'social-strength)
                    30 (layout 'wrap-content 'wrap-content 1 'centre 10))
         (spinner
          (make-id (string-append id-text "-strength-spinner"))
          (map mtext-lookup social-strength-list)
          (layout 'wrap-content 'wrap-content 1 'centre 0)
          (lambda (v)
            (entity-set-value! (string-append key "-strength") "varchar"
                               (spinner-choice social-strength-list 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))))
    (append
     (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)
     (list
      (mupdate
       'edit-text
       (string->symbol (string-append id-text "-nickname"))
       (string-append key "-nickname"))
      (mupdate-spinner
       (string->symbol (string-append id-text "-strength"))
       (string-append key "-strength")
       social-strength-list))
     )))

(define (build-amenity-widgets id shade)
  (let ((id-text (symbol->string id)))

    (horiz-colour
     (if shade colour-one colour-two)
     (linear-layout
      0 'vertical (layout 200 'wrap-content -1 'left 0)
      (list 0 0 0 0)
      (list
       (text-view (symbol->id id)
                  (mtext-lookup id)
                  30 (layout 'wrap-content 'wrap-content -1 'left 0))
       (mtoggle-button-scale
        (string->symbol (string-append id-text "-in-village"))
        (lambda (v)
          (entity-set-value! id-text "int" v)
          (list (update-widget
                 'edit-text
                 (get-id (string-append id-text "-closest-access-container"))
                 (if (eqv? v 1) 'hide 'show) 0))))))
     (medit-text-scale
      (string->symbol (string-append id-text "-closest-access"))
      "normal" (lambda (v) (entity-set-value!
                            (string-append id-text "-closest-access")
                            "varchar" v) '()))
     (vert
      (mbutton-scale
       (string->symbol (string-append id-text "-gps"))
       (lambda ()  (do-gps
                    (string->symbol (string-append id-text "-gps"))
                    (string-append id-text "-gps"))))
      (mtext-small (string->symbol (string-append id-text "-gps-lat")))
      (mtext-small (string->symbol (string-append id-text "-gps-lon")))))))

(define (update-amenity-widgets id)
  (let ((id-text (symbol->string id)))
    (append
     (list
      (mupdate 'toggle-button (string->symbol (string-append id-text "-in-village")) id-text)
      (mupdate 'edit-text
               (string->symbol (string-append id-text "-closest-access"))
               (string-append id-text "-closest-access"))
      (update-widget
       'edit-text
       (get-id (string-append id-text "-closest-access-container"))
       (if (eqv? (entity-get-value id-text) 1)
           'hide 'show) 0))
     (mupdate-gps
      (string->symbol (string-append id-text "-gps"))
      (string-append id-text "-gps")))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; activities

(define photo-code 999)
(define choose-code 998)
(define spouse-request-code 997)
(define mother-request-code 996)
(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

  (activity
   "main"
   (vert
    (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) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity requestcode resultcode) '()))

  (activity
   "main2"
   (build-activity
    (mtitle 'title)
    (horiz
     (medit-text 'user-id "normal"
                 (lambda (v)
                   (set-setting! "user-id" "varchar" v)
                   (set-current! 'user-id v)
                   (list)))

     (mspinner 'languages (list 'english 'khasi 'hindi)
               (lambda (c)
                 (set-setting! "language" "int" c)
                 (set! i18n-lang c)
                 (list)))
     (mbutton-scale 'find-individual (lambda () (list (start-activity "individual-chooser" choose-code "")))))

    (build-list-widget
     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...
              (if (zero? (length (db-filter-only
                                  db "sync" "household"
                                  (list (list "parent" "varchar" "="
                                              (get-setting-value "current-village")))
                                  (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")
                  (string-append
                   (ktv-get (get-entity-by-unique db "sync" (get-setting-value "current-village")) "name")
                   ":"
                   (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))))))

    (horiz
     (mbutton-scale 'villages (lambda () (list (start-activity "villages" 0 ""))))
     (mbutton-scale 'sync (lambda () (list (start-activity "sync" 0 "")))))
    )

   (lambda (activity arg)
     (activity-layout activity))
   (lambda (activity arg)
     (alog "start main start")
     (set-current! 'activity-title "Main screen")
     (set-current! 'village (get-setting-value "current-village"))
     (set-current! 'household #f)
     (set-current! 'individual #f)
     (let ((r (append
      (update-top-bar)
      (list
       (update-widget 'edit-text (get-id "user-id") 'text (get-setting-value "user-id"))
       (update-widget 'spinner (get-id "languages-spinner") 'selection
                      (get-setting-value "language"))
       (gps-start "gps" (lambda (loc)
                          (set-current! 'location loc)
                          (list (toast (string-append
                                        (number->string (car loc)) ", "
                                        (number->string (cadr loc)))))))
       (update-list-widget
        db "sync" (list "name") "household" "household" (get-setting-value "current-village"))))))
       (alog "end main start") r))
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity requestcode resultcode)
     (cond
      ((and (eqv? requestcode choose-code)
            (get-current 'choose-result 0))
       (list (start-activity "individual" 0 (get-current 'choose-result 0))))
      ((eqv? requestcode photo-code)
       (list (update-widget
              'image-view (get-id "image")
              'external-image (string-append dirname "photo.jpg"))))
      (else
       '()))))

  (activity
   "villages"
   (build-activity
    (mspinner 'current-village '()
              (lambda (v)
                (set-setting! "current-village" "varchar"
                              (cadr (list-ref (get-current 'villages-list '()) v)))
                '()))
    (build-list-widget
     db "sync" 'villages (list "name") "village" "village" (lambda () #f)
     (lambda () village-ktvlist)))


   (lambda (activity arg)
     (activity-layout activity))
   (lambda (activity arg)
     (set-current! 'activity-title "Villages")
     (set-current! 'villages-list (build-array-from-names db "sync" "village"))
     (append
      (update-top-bar)
      (list
       (update-widget 'spinner (get-id "current-village-spinner") 'array
                      (map car (get-current 'villages-list '())))
       (update-widget 'spinner (get-id "current-village-spinner") 'selection
                      (find-index-from-name-array
                       (get-current 'villages-list '())
                       (get-current 'village #f)))
       (update-list-widget db "sync" (list "name") "village" "village" #f))))
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity requestcode resultcode) '()))



  (activity
   "village"
   (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) '())))
      (horiz
       (medit-text 'district "normal" (lambda (v) (entity-set-value! "district" "varchar" v) '()))
       (mtoggle-button-scale 'car (lambda (v) (entity-set-value! "car" "int" v) '())))

      (mbutton 'household-list
               (lambda ()
                 (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)
      (build-amenity-widgets 'post-office #t)
      (build-amenity-widgets 'railway-station #f)
      (build-amenity-widgets 'state-bus-service #t)
      (build-amenity-widgets 'district-bus-service #f)
      (build-amenity-widgets 'panchayat #t)
      (build-amenity-widgets 'NGO #f)
      (build-amenity-widgets 'market #t)
      (delete-button))
   (lambda (activity arg)
     (activity-layout activity))
   (lambda (activity arg)
     (set-current! 'activity-title "Village")
     (entity-init! db "sync" "village" (get-entity-by-unique db "sync" arg))
     (set-current! 'village arg)
     (set-current! 'household #f)
     (set-current! 'individual #f)
     (append
      (update-top-bar)
      (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)
      (update-amenity-widgets 'hospital)
      (update-amenity-widgets 'post-office)
      (update-amenity-widgets 'railway-station)
      (update-amenity-widgets 'state-bus-service)
      (update-amenity-widgets 'district-bus-service)
      (update-amenity-widgets 'panchayat)
      (update-amenity-widgets 'NGO)
      (update-amenity-widgets 'market)))

   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity requestcode resultcode) '()))


  (activity
   "household-list"
   (build-activity
    (build-list-widget
     db "sync" 'households (list "name") "household" "household" (lambda () (get-current 'village #f))
     (lambda ()
       ;; autogenerate the name from the current ID
       (ktvlist-merge
        household-ktvlist
        (list (ktv "name" "varchar"
                   (string-append
                    (ktv-get (get-entity-by-unique db "sync" (get-setting-value "current-village")) "name")
                    (get-setting-value "user-id")
                    (number->string (get-next-id db "sync" "household" (get-setting-value "current-village"))))))))))
   (lambda (activity arg)
     (activity-layout activity))
   (lambda (activity arg)
     (set-current! 'activity-title "Households")
     (append
      (update-top-bar)
      (list (update-list-widget
             db "sync" (list "name") "household" "household" arg))))
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity requestcode resultcode) '()))

  (activity
   "household"
   (build-activity
    (horiz
     (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)
      (mbutton 'house-gps (lambda () (do-gps 'house "house")))
      (mtext-small 'house-lat)
      (mtext-small 'house-lon))
     (vert
      (mtext 'toilet-location)
      (mbutton 'toilet-gps (lambda () (do-gps 'toilet "toilet")))
      (mtext-small 'toilet-lat)
      (mtext-small 'toilet-lon)))


    (build-list-widget
     db "sync" 'individuals (list "name" "first-name" "family") "individual" "individual"
     (lambda () (get-current 'household #f))
     (lambda ()
       (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))
           (ktv "social-type" "varchar"
                (symbol->string
                 (list-ref social-types-list
                           (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)
     (activity-layout activity))
   (lambda (activity arg)
     (set-current! 'activity-title "Household")
     (entity-init! db "sync" "household" (get-entity-by-unique db "sync" arg))
     (set-current! 'household arg)
     (set-current! 'individual #f)
     (append
      (update-top-bar)
      (list
       (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")
      (mupdate-gps 'toilet "toilet")))

   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity) '())
   (lambda (activity requestcode resultcode) '()))

  (activity
   "individual"
   (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))
         )))

     (vert
      (mtext 'name-display)
      (spacer 20)
      (mtext 'first-name-display)
      (spacer 20)
      (mtext 'family-display)
      (spacer 20)
      (mtext 'photo-id-display)
      ))
    (mtext 'last-editor)
    (horiz
     (mbutton-scale 'agreement-button (lambda () (list (start-activity "agreement" 0 ""))))
     (mbutton-scale 'details-button (lambda () (list (start-activity "details" 0 "")))))
    (horiz
     (mbutton-scale 'family-button (lambda () (list (start-activity "family" 0 ""))))
     (mbutton-scale 'migration-button (lambda () (list (start-activity "migration" 0 "")))))
    (horiz
     (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 '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)
     (activity-layout activity))
   (lambda (activity arg)
     (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
       (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")
       (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")
       (mupdate 'image-view 'photo "photo"))))