Commit 79a2694d authored by Dave Griffiths's avatar Dave Griffiths
Browse files

download fixes

parent 5cc16103
......@@ -463,8 +463,9 @@
"Stream data: " (number->string (car stream)) "/" (number->string (cadr stream)))))
(define (upload-dirty db)
(msg "upload-dirty called")
(let ((r (append
(spit db "sync" (dirty-entities db "sync"))
(spit db "sync" (dbg (dirty-entities db "sync")))
(spit db "stream" (dirty-entities db "stream")))))
(append (cond
((> (length r) 0)
......@@ -914,186 +915,6 @@
(_ arr 0))
(define (simpsons-village db table default-ktvlist)
(entity-create! db table "village"
(ktvlist-merge
default-ktvlist
(list
(ktv "name" "varchar" (string-append "Village-" (number->string (random 1000))))
(ktv "block" "varchar" (word-gen))
(ktv "district" "varchar" (word-gen))
(ktv "car" "int" (random 2))))))
(define (simpsons-household db table parent default-ktvlist)
(entity-create! db table "household"
(ktvlist-merge
default-ktvlist
(list
(ktv "name" "varchar" (string-append "Household-" (number->string (random 1000))))
(ktv "num-pots" "int" (random 10))
(ktv "parent" "varchar" parent)))))
(define (simpsons-individual db table parent default-ktvlist)
(let ((n (random 1000)))
(entity-create! db table "individual"
(ktvlist-merge
default-ktvlist
(append
(list (ktv "parent" "varchar" parent))
(choose
(list
(list
(ktv "name" "varchar"
(string-append "Abe-" (number->string n)))
(ktv "gender" "varchar" "male")
(ktv "photo" "file" "abe.jpg"))
(list
(ktv
"name" "varchar" (string-append "Akira-" (number->string n)))
(ktv "gender" "varchar" "male")
(ktv "photo" "file" "akira.jpg"))
(list
(ktv
"name" "varchar" (string-append "Apu-" (number->string n)))
(ktv "gender" "varchar" "male")
(ktv "photo" "file" "apu.jpg"))
(list
(ktv
"name" "varchar" (string-append "Barney-" (number->string n)))
(ktv "gender" "varchar" "male")
(ktv "photo" "file" "barney.jpg"))
(list
(ktv
"name" "varchar" (string-append "Bart-" (number->string n)))
(ktv "gender" "varchar" "male")
(ktv "photo" "file" "bartsimpson.jpg"))
(list
(ktv
"name" "varchar" (string-append "Billy-" (number->string n)))
(ktv "gender" "varchar" "male")
(ktv "photo" "file" "billy.jpg"))
(list
(ktv
"name" "varchar" (string-append "Carl-" (number->string n)))
(ktv "gender" "varchar" "male")
(ktv "photo" "file" "carl.jpg"))
(list
(ktv
"name" "varchar" (string-append "Cletus-" (number->string n)))
(ktv "gender" "varchar" "male")
(ktv "photo" "file" "cletus.jpg"))
(list
(ktv
"name" "varchar" (string-append "ComicBookGuy-" (number->string n)))
(ktv "gender" "varchar" "male")
(ktv "photo" "file" "comicbookguy.jpg"))
(list
(ktv
"name" "varchar" (string-append "Homer-" (number->string n)))
(ktv "gender" "varchar" "male")
(ktv "photo" "file" "homersimpson.jpg"))
(list
(ktv
"name" "varchar" (string-append "Jasper-" (number->string n)))
(ktv "gender" "varchar" "male")
(ktv "photo" "file" "jasper.jpg"))
(list
(ktv
"name" "varchar" (string-append "Kent-" (number->string n)))
(ktv "gender" "varchar" "male")
(ktv "photo" "file" "kentbrockman.jpg"))
(list
(ktv
"name" "varchar" (string-append "Kodos-" (number->string n)))
(ktv "gender" "varchar" "male")
(ktv "photo" "file" "kodos.jpg"))
(list
(ktv
"name" "varchar" (string-append "Lenny-" (number->string n)))
(ktv "gender" "varchar" "male")
(ktv "photo" "file" "lenny.jpg"))
(list
(ktv
"name" "varchar" (string-append "Lisa-" (number->string n)))
(ktv "gender" "varchar" "female")
(ktv "photo" "file" "lisasimpson.jpg"))
(list
(ktv
"name" "varchar" (string-append "Marge-" (number->string n)))
(ktv "gender" "varchar" "female")
(ktv "photo" "file" "margesimpson.jpg"))
(list
(ktv
"name" "varchar" (string-append "Martin-" (number->string n)))
(ktv "gender" "varchar" "male")
(ktv "photo" "file" "martinprince.jpg"))
(list
(ktv
"name" "varchar" (string-append "Milhouse-" (number->string n)))
(ktv "gender" "varchar" "male")
(ktv "photo" "file" "milhouse.jpg"))
(list
(ktv
"name" "varchar" (string-append "MrBurns-" (number->string n)))
(ktv "gender" "varchar" "male")
(ktv "photo" "file" "mrburns.jpg"))
(list
(ktv
"name" "varchar" (string-append "Ned-" (number->string n)))
(ktv "gender" "varchar" "male")
(ktv "photo" "file" "nedflanders.jpg"))
(list
(ktv
"name" "varchar" (string-append "Nelson-" (number->string n)))
(ktv "gender" "varchar" "male")
(ktv "photo" "file" "nelson.jpg"))
(list
(ktv
"name" "varchar" (string-append "Otto-" (number->string n)))
(ktv "gender" "varchar" "male")
(ktv "photo" "file" "otto.jpg"))
(list
(ktv
"name" "varchar" (string-append "Ralph-" (number->string n)))
(ktv "gender" "varchar" "male")
(ktv "photo" "file" "ralphwiggum.jpg"))
(list
(ktv
"name" "varchar" (string-append "Santaslittlehelper-" (number->string n)))
(ktv "gender" "varchar" "male")
(ktv "photo" "file" "santaslittlehelper.jpg"))
(list
(ktv
"name" "varchar" (string-append "SideshowBob-" (number->string n)))
(ktv "gender" "varchar" "male")
(ktv "photo" "file" "sideshowbob.jpg")))))))))
(define (looper! n fn)
(when (not (zero? n))
(fn n)
(looper! (- n 1) fn)))
(define (build-test! db table village-ktvlist household-ktvlist individual-ktvlist)
(looper!
1
(lambda (i)
(msg "making village" i)
(let ((village (simpsons-village db table village-ktvlist)))
(looper!
3
(lambda (i)
(alog "household")
(msg "making household" i)
(let ((household (simpsons-household db table village household-ktvlist)))
(looper!
(random 10)
(lambda (i)
(msg "making individual" i)
(simpsons-individual db table household individual-ktvlist))))))))))
(define (mangle-test! db table entities)
(define (_ n)
(when (not (zero? n))
......@@ -1315,6 +1136,26 @@
(vector-ref i 0))
(cdr s)))))
(define (all-entities-in-date-range db table type start end)
(let ((s (db-select
db (string-append
"select e.entity_id from " table "_entity as e "
"join " table "_value_varchar "
"as t on t.entity_id = e.entity_id "
"where entity_type = ? and t.attribute_id = ? "
"and t.value > DateTime(?) and t.value <= DateTime(?) "
"order by t.value desc")
type "time" start end
)))
(msg (db-status db))
(if (null? s)
'()
(map
(lambda (i)
(vector-ref i 0))
(cdr s)))))
(define (db-all-sort-normal db table type)
......@@ -1388,3 +1229,12 @@
(all-entities-where-older db table type ktv ktv2))))
(prof-end "db-all-where older")
r))
(define (db-all-with-parent db table type parent)
(prof-start "db-all")
(let ((r (map
(lambda (i)
(get-entity db table i))
(all-entities-with-parent db table type parent))))
(prof-end "db-all")
r))
......@@ -450,6 +450,13 @@
"\n" token ": " value))))))
(string-append "{" (_ l "") "\n" "}"))
;; save text to the sdcard (for csv etc)
(define (save-data filename d)
(let ((f (open-output-file (string-append dirname filename))))
(display d f)
(close-output-port f))
d)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; android ui
......
......@@ -27,7 +27,12 @@
"pup-focal-pupaggr"
"group-interaction"
"group-alarm"
"group-move"))
"group-move"
"group-composition"
"weight"
"pup-assoc"
"mate-guard"
))
(define pup-focal-export
(list
......@@ -707,17 +712,17 @@
(vert
(spacer 30)
(horiz
(mbutton (string-append id "-backb") "Back"
(lambda ()
(list (replace-fragment (get-id "gc-top") last-frag))))
(mbutton (string-append id "-nextb") "Next"
(lambda ()
(entity-update-values!)
(append
(fn)
(list
(replace-fragment (get-id "gc-top") next-frag))))))))
(button (make-id (string-append id "-backb")) "Back" 30 (layout 'fill-parent 'wrap-content 1 'centre 5)
(lambda ()
(list (replace-fragment (get-id "gc-top") last-frag))))
(button (make-id (string-append id "-nextb")) "Next" 30 (layout 'fill-parent 'wrap-content 1 'centre 5)
(lambda ()
(entity-update-values!)
(append
(fn)
(list
(replace-fragment (get-id "gc-top") next-frag))))))))
(define (force-pause)
(list
......
......@@ -528,6 +528,11 @@
(append
(list
(update-widget 'edit-text (get-id "gc-start-code") 'text
(entity-get-value "group-comp-code"))
(update-widget 'toggle-button (get-id "gc-start-main-obs") 'checked
(entity-get-value "main-observer"))
(populate-grid-selector
"gc-start-present" "toggle"
(db-mongooses-by-pack) #f
......@@ -661,7 +666,11 @@
'()))))
(build-grid-selector "gc-pup-escort" "toggle" "Escort")
(next-button "gc-pup-assoc-" "Going to oestrus, have you finished here?" "gc-preg" "gc-oestrus"
(lambda () '()))))
(lambda ()
;; reset main entity
(entity-init! db "stream" "group-composition"
(get-entity-by-unique db "stream" (get-current 'group-composition-id #f)))
'()))))
(lambda (fragment arg)
(activity-layout fragment))
......@@ -768,7 +777,11 @@
)
(build-grid-selector "gc-oestrus-guard" "toggle" "Choose mate guard")
(next-button "gc-pup-oestrus-" "Going to babysitters, have you finished here?" "gc-pup-assoc" "gc-babysitting"
(lambda () '()))))
(lambda ()
;; reset main entity
(entity-init! db "stream" "group-composition"
(get-entity-by-unique db "stream" (get-current 'group-composition-id #f)))
'()))))
(lambda (fragment arg)
(activity-layout fragment))
(lambda (fragment arg)
......@@ -941,8 +954,7 @@
(spacer 10)
(horiz
(mbutton2 "main-observations" "Observations" (lambda () (list (start-activity "observations" 2 ""))))
(mbutton2 "main-manage" "Manage Packs" (lambda () (list (start-activity "manage-packs" 2 ""))))
(mbutton2 "main-tag" "Tag Location" (lambda () (list (start-activity "tag-location" 2 "")))))
(mbutton2 "main-manage" "Manage Packs" (lambda () (list (start-activity "manage-packs" 2 "")))))
(image-view 0 "mongooses" fillwrap)
(mtext "foo" "Your ID")
......@@ -1041,7 +1053,8 @@
'group-composition-id
(entity-init&save!
db "stream" "group-composition"
(list (ktv "pack" "varchar" (ktv-get (get-current 'pack ()) "unique_id"))))))
(list (ktv "pack" "varchar" (ktv-get (get-current 'pack ()) "unique_id"))
(ktv "group-comp-code" "varchar" "")))))
(list
(start-activity "group-composition" 2 ""))))
(list
......@@ -1085,7 +1098,19 @@
(list 0 0 0 0)
(horiz
(text-view (make-id "obs-title") "" 40 fillwrap)
(mbutton-small "gc-done" "Exit" (lambda () (list (finish-activity 0))))))
(mbutton-small "gc-done" "Exit"
(lambda ()
(list
(alert-dialog
"gc-end-done"
"Finish group composition: are you sure?"
(lambda (v)
(cond
((eqv? v 1)
(list (finish-activity 1)))
(else
(list))))))))))
(build-fragment "gc-start" (make-id "gc-top") (layout 'fill-parent 'wrap-content -1 'left 0))
......
......@@ -69,3 +69,83 @@
db (string-append
"select entity_id, unique_id from "
table "_entity where entity_type = ?") entity-type))))
;; exporting human editable reports
(define (deref-entity entity)
(foldl
(lambda (ktv r)
(append
r
(list
(ktv-key ktv)
(cond
;; dereferences lists of ids
((and
(> (string-length (ktv-key ktv)) 8)
(equal? (substring (ktv-key ktv) 0 8) "id-list-"))
(get-entity-names db "sync" (string-split (ktv-value ktv) '(#\,))))
;; look for unique ids and dereference them
((and
(> (string-length (ktv-key ktv)) 3)
(equal? (substring (ktv-key ktv) 0 3) "id-"))
(get-entity-name db "sync" (ktv-value ktv)))
(else
(ktv-value ktv))))))
'()
entity))
(define (csv-convert col)
(if (number? col) (number->string col)
(if (string? col) col
(begin
(msg "csvify found:" col) "oops"))))
;; convert list of lists into comma seperated columns
;; and newline seperated rows
(define (csvify l)
(foldl
(lambda (row r)
(let ((row-text
(foldl
(lambda (col r)
(let ((converted (csv-convert col)))
(if (equal? r "")
converted
(string-append r ", " converted))))
"" row)))
(msg row-text)
(dbg (string-append r row-text "\n"))))
"" l))
;; meant to be general, but made for pup focal reports
(define (export-csv db table parent-entity entity-types)
(let* ((focal (get-entity db "sync" (get-entity-id db "sync" (ktv-get parent-entity "id-focal-subject"))))
(pack (get-entity db "sync" (get-entity-id db "sync" (ktv-get focal "pack-id")))))
(csvify
(cons
'("time" "user" "pack" "subject" "observation type" "key" "value" "key" "value")
(sort
(foldl
(lambda (entity-type r)
(append
r (map
(lambda (entity)
(append
(list
(ktv-get entity "time")
(ktv-get entity "user")
(ktv-get pack "name")
(ktv-get focal "name")
entity-type)
(deref-entity
(ktv-filter-many
entity (list "user" "unique_id" "parent" "time")))))
(db-all-with-parent
db table entity-type
(ktv-get parent-entity "unique_id")))))
'()
entity-types)
(lambda (a b)
(string<? (car a) (car b))))))))
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