Commit df7416c2 authored by dave griffiths's avatar dave griffiths
Browse files

merge fix

parents b16d27ce fa919cc6
<?xml version="1.0" encoding="utf-8"?>
<manifest xmlns:android="http://schemas.android.com/apk/res/android"
package="foam.mongoose"
android:versionCode="11"
android:versionCode="12"
android:versionName="1.0">
<application android:label="@string/app_name"
android:icon="@drawable/logo"
......
......@@ -179,7 +179,7 @@
(unique-id
(update-entity db table (entity-id-from-unique db table unique-id) (list ktv)))
(else
(msg "no values or no id to update as entity:" unique-id "values:" value)))))
(msg "no values or no id to update as entity:" unique-id "values:" ktv)))))
(define (entity-reset!)
......@@ -197,19 +197,21 @@
entities))
(define (string-split-simple str delim)
(let ((r (foldl
(lambda (c r)
(cond
((eqv? c delim)
(list "" (append (cadr r) (list (car r)))))
(else
(list (string-append (car r) (string c))
(cadr r)))))
(list "" '())
(string->list str))))
(if (equal? (car r) "")
(cadr r)
(append (cadr r) (list (car r))))))
(string-split str (list delim)))
; (let ((r (foldl
; (lambda (c r)
; (cond
; ((eqv? c delim)
; (list "" (append (cadr r) (list (car r)))))
; (else
; (list (string-append (car r) (string c))
; (cadr r)))))
; (list "" '())
; (string->list str))))
; (if (equal? (car r) "")
; (cadr r)
; (append (cadr r) (list (car r))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; syncing code
......@@ -461,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)
......@@ -698,11 +701,34 @@
(string-append dirname "files/" image-name)))))
(else (msg "mupdate-widget unhandled widget type" widget-type))))
;(define (spinner-choice l i)
; (if (number? i)
; (symbol->string (list-ref l i))
; i))
;; spinner options are (list 'id-sym "Name") ...
(define (spinner-choice l i)
(if (number? i)
(symbol->string (list-ref l i))
(symbol->string (car (list-ref l i)))
i))
(define (spinner-index l s)
(define (_ l n s)
(cond
((null? l) 0)
((eq? (car (car l)) s) n)
((_ (cdr l) (+ n 1) s))))
(_ l 0 (string->symbol s)))
(define (spinner-index->name l i)
(define (_ l n)
(cond
((null? l) "Unknown")
((zero? n) (cadr (car l)))
((_ (cdr l) (- n 1)))))
(_ l i))
(define (mupdate-spinner id-symbol key choices)
(let* ((val (entity-get-value key)))
(if (not val)
......@@ -889,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))
......@@ -1290,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)
......@@ -1363,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))
......@@ -338,6 +338,16 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (string-remove-whitespace str)
(define (_ i)
(cond
((>= i (string-length str)) "")
((char-whitespace? (string-ref str i))
(_ (+ i 1)))
(else (string-append (string (string-ref str i))
(_ (+ i 1))))))
(_ 0))
(define (string-split str . rest)
; maxsplit is a positive number
(define (split-by-whitespace str maxsplit)
......@@ -440,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
......@@ -659,7 +676,7 @@
(define wrap (layout 'wrap-content 'wrap-content 1 'left 0))
(define fillwrap (layout 'fill-parent 'wrap-content 1 'left 0))
(define wrapfill (layout 'wrap-content 'fill-parent 1 'left 0))
(define fill (layout 'fill-parent 'fill-parent 1 'left 0))
(define fill (layout 'fill-parent 'fill-parent 1 'left 10))
(define (spacer size) (space (layout 'fill-parent size 1 'left 0)))
......@@ -701,7 +718,7 @@
(define (relative rules colour . l)
(relative-layout
0 (rlayout 'fill-parent 'wrap-content 20 rules)
0 (rlayout 'fill-parent 'wrap-content (list 20 20 20 20) rules)
colour
l))
......
This diff is collapsed.
This diff is collapsed.
......@@ -110,6 +110,7 @@ public class starwisp extends StarwispActivity
m_Scheme.Load("eavdb/entity-csv.ss");
m_Scheme.Load("eavdb/eavdb.ss");
m_Scheme.Load("dbsync.scm");
m_Scheme.Load("mongoose.scm");
m_Builder = new StarwispBuilder(m_Scheme);
......
......@@ -113,3 +113,84 @@
entity))))
(csv-titles db table entity-type)
(cdr s)))))
;; 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))))))))
......@@ -60,7 +60,7 @@
(else c)))
(string->list var))))
(define (build-query table filter)
(define (build-query table filter typed)
(string-append
(foldl
(lambda (i r)
......@@ -78,12 +78,13 @@
;; 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 "
;; ignore deleted (if exists)
"left join " table "_value_int "
"as d on d.entity_id = e.entity_id and d.attribute_id = 'deleted' and "
"d.value = 0 ")
"d.value = 0 or d.value = NULL ")
filter)
"where e.entity_type = ? order by n.value"))
(if typed "where e.entity_type = ? order by n.value"
"order by n.value")))
(define (build-args filter)
(map
......@@ -95,9 +96,9 @@
(let ((s (apply
db-select
(append
(list db (build-query table filter))
(list db (build-query table filter (not (equal? type "*"))))
(build-args filter)
(list type)))))
(if (equal? type "*") '() (list type))))))
(msg (db-status db))
(if (null? s)
'()
......
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