Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
Dave Griffiths
mongoose-2000
Commits
4492c06f
Commit
4492c06f
authored
Jul 16, 2014
by
Dave Griffiths
Browse files
imported symbai version of base stuff
parent
df7416c2
Changes
7
Hide whitespace changes
Inline
Side-by-side
Showing
7 changed files
with
107 additions
and
44 deletions
+107
-44
eavdb/eavdb.ss
eavdb/eavdb.ss
+9
-4
eavdb/entity-csv.ss
eavdb/entity-csv.ss
+45
-33
eavdb/entity-filter.ss
eavdb/entity-filter.ss
+40
-1
eavdb/entity-insert.ss
eavdb/entity-insert.ss
+1
-2
eavdb/entity-sync.ss
eavdb/entity-sync.ss
+2
-1
eavdb/entity-values.ss
eavdb/entity-values.ss
+3
-3
eavdb/ktv-list.ss
eavdb/ktv-list.ss
+7
-0
No files found.
eavdb/eavdb.ss
View file @
4492c06f
...
...
@@ -63,11 +63,10 @@
;; helpers
(
define
(
db-all
db
table
type
)
(
msg
"db-all"
)
(
map
(
lambda
(
i
)
(
get-entity
db
table
i
))
(
dbg
(
all-entities
db
table
type
)))
)
(
all-entities
db
table
type
)))
(
define
(
db-with-parent
db
table
type
parent
)
(
map
...
...
@@ -83,8 +82,14 @@
;; only return (eg. name and photo)
(
define
(
db-filter-only
db
table
type
filter
kt-list
)
(
msg
"db-filter-only"
)
(
map
(
lambda
(
i
)
(
get-entity-only
db
table
i
kt-list
))
(
dbg
(
filter-entities
db
table
type
filter
))))
(
filter-entities
db
table
type
filter
)))
;; only return (eg. name and photo)
(
define
(
db-filter-only-inc-deleted
db
table
type
filter
kt-list
)
(
map
(
lambda
(
i
)
(
get-entity-only
db
table
i
kt-list
))
(
filter-entities-inc-deleted
db
table
type
filter
)))
eavdb/entity-csv.ss
View file @
4492c06f
...
...
@@ -89,7 +89,6 @@
"select entity_id, unique_id from "
table
"_entity where entity_type = ?"
)
entity-type
)))
(
msg
"CSV ------------------------------>"
entity-type
)
(
msg
s
)
(
if
(
null?
s
)
;; nothing here, just return titles
(
csv-titles
db
table
entity-type
)
...
...
@@ -100,7 +99,6 @@
r
"\n"
(
foldl
(
lambda
(
ktv
r
)
(
msg
ktv
)
(
cond
((
equal?
(
ktv-key
ktv
)
"unique_id"
)
r
)
((
null?
(
ktv-value
ktv
))
...
...
@@ -116,7 +114,7 @@
;; exporting human editable reports
(
define
(
deref-entity
entity
)
(
define
(
deref-entity
db
entity
)
(
foldl
(
lambda
(
ktv
r
)
(
append
...
...
@@ -160,37 +158,51 @@
(
string-append
r
", "
converted
))))
""
row
)))
(
msg
row-text
)
(
dbg
(
string-append
r
row-text
"\n"
)))
)
(
string-append
r
row-text
"\n"
)))
""
l
))
(
define
(
ktv-filter
ktv-list
key
)
(
filter
(
lambda
(
ktv
)
(
not
(
equal?
(
ktv-key
ktv
)
key
)))
ktv-list
))
(
define
(
ktv-filter-many
ktv-list
key-list
)
(
foldl
(
lambda
(
key
r
)
(
ktv-filter
r
key
))
ktv-list
key-list
))
;; 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
))))))))
;
(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
; db
(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))))))))
eavdb/entity-filter.ss
View file @
4492c06f
...
...
@@ -86,6 +86,28 @@
(
if
typed
"where e.entity_type = ? order by n.value"
"order by n.value"
)))
(
define
(
build-query-inc-deleted
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' "
)
filter
)
"where e.entity_type = ? order by n.value"
))
(
define
(
build-args
filter
)
(
map
(
lambda
(
i
)
...
...
@@ -93,6 +115,23 @@
filter
))
(
define
(
filter-entities
db
table
type
filter
)
(
let
((
q
(
build-query
table
filter
(
not
(
equal?
type
"*"
)))))
(
let
((
s
(
apply
db-select
(
append
(
list
db
q
)
(
build-args
filter
)
(
list
type
)))))
(
msg
(
db-status
db
))
(
if
(
null?
s
)
'
()
(
map
(
lambda
(
i
)
(
vector-ref
i
0
))
(
cdr
s
))))))
(
define
(
filter-entities-inc-deleted
db
table
type
filter
)
(
let
((
q
(
build-query-inc-deleted
table
filter
)))
(
let
((
s
(
apply
db-select
(
append
...
...
@@ -105,4 +144,4 @@
(
map
(
lambda
(
i
)
(
vector-ref
i
0
))
(
cdr
s
)))))
(
cdr
s
)))))
)
eavdb/entity-insert.ss
View file @
4492c06f
...
...
@@ -65,8 +65,7 @@
;; add all the keys
(
for-each
(
lambda
(
ktv
)
(
msg
"inserting"
ktv
)
(
insert-value
db
table
id
ktv
dirty
))
(
insert-value
db
table
id
ktv
(
not
(
zero?
dirty
))))
ktvlist
)
(
db-exec
db
"end transaction"
)
...
...
eavdb/entity-sync.ss
View file @
4492c06f
...
...
@@ -68,7 +68,8 @@
(
define
(
dirty-entities
db
table
)
(
let
((
de
(
db-select
db
(
string-append
"select entity_id, entity_type, unique_id, dirty, version from "
table
"_entity where dirty=1;"
))))
"select entity_id, entity_type, unique_id, dirty, version from "
table
"_entity where dirty=1 limit 5;"
))))
(
if
(
null?
de
)
'
()
(
map
...
...
eavdb/entity-values.ss
View file @
4492c06f
...
...
@@ -88,7 +88,7 @@
;;(msg ktv)
;;(msg entity-id)
(
if
(
null?
s
)
(
insert-value
db
table
entity-id
ktv
#t
)
(
insert-value
db
table
entity-id
ktv
#t
)
;; <- don't make dirty!?
(
db-exec
db
(
string-append
"update "
table
"_value_"
(
ktv-type
ktv
)
" set value=?, dirty=0 where entity_id = ? and attribute_id = ?"
)
...
...
@@ -114,8 +114,8 @@
" where entity_id = ? and attribute_id = ?"
)
entity-id
(
ktv-key
kt
))))
(
if
(
null?
s
)
'
()
(
list
(
vector-ref
(
cadr
s
)
0
)
(
vector-ref
(
cadr
s
)
1
)))))
(
list
(
vector-ref
(
cadr
s
)
0
)
(
vector-ref
(
cadr
s
)
1
)))))
(
define
(
clean-value
db
table
entity-id
kt
)
(
db-exec
db
(
string-append
"update "
table
"_value_"
(
ktv-type
kt
)
...
...
eavdb/ktv-list.ss
View file @
4492c06f
...
...
@@ -25,6 +25,13 @@
(
ktv-value
(
car
ktv-list
)))
(
else
(
ktv-get
(
cdr
ktv-list
)
key
))))
(
define
(
ktv-get-whole
ktv-list
key
)
(
cond
((
null?
ktv-list
)
#f
)
((
equal?
(
ktv-key
(
car
ktv-list
))
key
)
(
car
ktv-list
))
(
else
(
ktv-get-whole
(
cdr
ktv-list
)
key
))))
(
define
(
ktv-get-type
ktv-list
key
)
(
cond
((
null?
ktv-list
)
#f
)
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment