deleting old semantic-db code
Alex Chapman
parent
cdcc101270
commit
229e9835fb
|
|
@ -1,26 +0,0 @@
|
|||
USING: io.files kernel namespaces semantic-db.db semantic-db.db.private sqlite tools.test ;
|
||||
IN: temporary
|
||||
|
||||
[ "n.id" ] [ "id" "n" [ 0 column-text ] <field> field-sql ] unit-test
|
||||
[ "select n.id from nodes n where n.content = :content" ] [
|
||||
<query>
|
||||
"id" "n" [ 0 column-text ] <field> over add-field
|
||||
"nodes n" over add-table
|
||||
"n.content = :content" over add-condition
|
||||
query-sql
|
||||
] unit-test
|
||||
|
||||
[
|
||||
create-node-table create-arc-table
|
||||
[ 1 ] [ "first node" create-node ] unit-test
|
||||
[ 2 ] [ "second node" create-node ] unit-test
|
||||
[ 3 ] [ "third node" create-node ] unit-test
|
||||
[ 4 ] [ f create-node ] unit-test
|
||||
[ "first node" ] [ 1 node-content ] unit-test
|
||||
[ 5 ] [ 1 2 3 create-arc ] unit-test
|
||||
[ { { 1 2 3 } } ] [ 2 node-arcs ] unit-test
|
||||
[ { { 1 2 3 } } ] [ 3 node-arcs ] unit-test
|
||||
[ { { 3 1 } } ] [ 2 node-subject-arcs ] unit-test
|
||||
[ { { 2 1 } } ] [ 3 node-object-arcs ] unit-test
|
||||
]
|
||||
with-tmp-db
|
||||
|
|
@ -1,281 +0,0 @@
|
|||
! Copyright (C) 2007, 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs kernel math namespaces new-slots sequences sqlite ;
|
||||
IN: semantic-db.db
|
||||
|
||||
! sqlite utils
|
||||
: prepare ( string -- statement )
|
||||
db get swap sqlite-prepare ;
|
||||
|
||||
: binding ( statement key val -- statement )
|
||||
>r dup integer? [ 1+ ] when dupd r> sqlite-bind-by-name-or-index ;
|
||||
|
||||
GENERIC# bindings 1 ( bindings statement -- statement )
|
||||
|
||||
M: assoc bindings
|
||||
swap [ binding ] assoc-each ;
|
||||
|
||||
M: sequence bindings
|
||||
swap dup length swap [ binding ] 2each ;
|
||||
|
||||
: prepare-with-bindings ( bindings string -- statement )
|
||||
prepare bindings ;
|
||||
|
||||
: select-with-bindings ( bindings string quot -- results )
|
||||
>r prepare-with-bindings dup r> sqlite-map swap sqlite-finalize ;
|
||||
|
||||
: ignore-and-finalize ( statement -- )
|
||||
dup [ drop ] sqlite-each sqlite-finalize ;
|
||||
|
||||
: sql-update ( string -- )
|
||||
prepare ignore-and-finalize ;
|
||||
|
||||
: update-with-bindings ( bindings string -- )
|
||||
prepare-with-bindings ignore-and-finalize ;
|
||||
|
||||
: 1result ( array -- result )
|
||||
#! return the first (and hopefully only) element of the array, or f
|
||||
dup length zero? [ drop f ] [ first ] if ;
|
||||
|
||||
: (collect-int-columns) ( statement n -- )
|
||||
[ dupd column-int , ] each drop ;
|
||||
|
||||
: collect-int-columns ( statement n -- columns )
|
||||
[ (collect-int-columns) ] { } make ;
|
||||
|
||||
! queries
|
||||
TUPLE: field name table retriever ;
|
||||
C: <field> field
|
||||
|
||||
TUPLE: query fields tables conditions args statement results ;
|
||||
|
||||
: call-field-retrievers ( query
|
||||
|
||||
: <query> ( -- query )
|
||||
V{ } clone V{ } clone V{ } clone H{ } clone f f
|
||||
query construct-boa ;
|
||||
|
||||
: invalidate-query ( query -- query )
|
||||
f >>results ;
|
||||
|
||||
: add-field ( field query -- query )
|
||||
dup invalidate-query fields>> push ;
|
||||
|
||||
: add-table ( table query -- query )
|
||||
dup invalidate-query tables>> push ;
|
||||
|
||||
: add-condition ( condition query -- query )
|
||||
tuck invalidate-query conditions>> push ;
|
||||
|
||||
: add-arg ( arg key query -- query )
|
||||
[ invalidate-query args>> set-at ] keep ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: field-sql ( field -- sql )
|
||||
[ dup table>> % CHAR: . , name>> % ] "" make ;
|
||||
|
||||
: fields-sql ( query -- sql )
|
||||
fields>> dup length [
|
||||
[ field-sql ] map ", " join
|
||||
] [
|
||||
drop "*"
|
||||
] if ;
|
||||
|
||||
: tables-sql ( query -- sql )
|
||||
tables>> ", " join ;
|
||||
|
||||
: conditions-sql ( query -- sql )
|
||||
conditions>> dup length [
|
||||
" and " join "where " swap append
|
||||
] [
|
||||
drop ""
|
||||
] if ;
|
||||
|
||||
: query-sql ( query -- sql )
|
||||
[
|
||||
"select" , dup fields-sql , dup "from" , tables-sql , conditions-sql ,
|
||||
] { } make " " join ;
|
||||
|
||||
: prepare-query ( query -- query )
|
||||
dup query-sql prepare >>statement ;
|
||||
|
||||
: bind-query ( query -- query )
|
||||
dup args>> over statement>> bindings >>statement ;
|
||||
|
||||
: (retrieve) ( statement query -- result )
|
||||
fields>> swap [ retriever>> call ] curry each ;
|
||||
|
||||
: retrieve ( query -- query )
|
||||
dup statement>> over [ (retrieve) ] curry sqlite-map
|
||||
swap >>results ;
|
||||
! dup query-statement over query-retriever sqlite-map swap >>results ;
|
||||
|
||||
: finalize-query ( query -- query )
|
||||
statement>> dup sqlite-finalize f swap >>statement ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: run-query ( query -- )
|
||||
dup prepare-query dup bind-query dup retrieve finalize-query ;
|
||||
|
||||
: get-results ( query -- results )
|
||||
dup results>> [ nip ] [ dup run-query results>> ] if* ;
|
||||
|
||||
! nodes and arcs
|
||||
|
||||
! maybe merge nodes and arcs table, so arcs can be nodes too:
|
||||
! create table nodes (id integer primary key autoincrement, value none, type integer, subject integer, object integer)
|
||||
! nodes:
|
||||
! value: node content
|
||||
! type: nid of node type
|
||||
! subject: null
|
||||
! object: null
|
||||
!
|
||||
! arcs:
|
||||
! value: ordinality, or null
|
||||
! type: nid of relation
|
||||
! subject: nid of arc subject
|
||||
! object: nid of arc object
|
||||
!
|
||||
! An alternative layout:
|
||||
!
|
||||
! nodes:
|
||||
! id
|
||||
! type
|
||||
!
|
||||
! content:
|
||||
! id
|
||||
! content
|
||||
!
|
||||
! arcs:
|
||||
! id
|
||||
! relation
|
||||
! subject
|
||||
! object
|
||||
! ordinal
|
||||
!
|
||||
! A third alternative. In this, all arcs have an entry in the nodes table, but
|
||||
! their content is null. No node that isn't an arc can have null content. If an
|
||||
! arc needs an ordinal, then it can be created as another arc.
|
||||
!
|
||||
! nodes:
|
||||
! id
|
||||
! content
|
||||
!
|
||||
! arcs:
|
||||
! id
|
||||
! relation
|
||||
! subject
|
||||
! object
|
||||
|
||||
: create-node-table ( -- )
|
||||
"create table nodes (id integer primary key autoincrement, content none);" sql-update ;
|
||||
|
||||
: create-arc-table ( -- )
|
||||
"create table arcs (id integer, relation integer, subject integer, object integer);" sql-update ;
|
||||
|
||||
: create-node ( content -- id )
|
||||
#! if content is f then it is inserted as NULL
|
||||
[ 1array ] [ drop { } clone ] if*
|
||||
"insert into nodes (content) values (?);"
|
||||
update-with-bindings db get sqlite-last-insert-rowid ;
|
||||
|
||||
: create-bootstrap-nodes ( -- )
|
||||
{ "context" "relation" "is of type" "semantic-db" "is in context" }
|
||||
[ create-node drop ] each ;
|
||||
|
||||
: context-type 1 ; inline
|
||||
: relation-type 2 ; inline
|
||||
: has-type-relation 3 ; inline
|
||||
: semantic-db-context 4 ; inline
|
||||
: has-context-relation 5 ; inline
|
||||
|
||||
: create-arc ( relation subject object -- id )
|
||||
f create-node -roll 4array
|
||||
"insert into arcs (id, relation, subject, object) values (?, ?, ?, ?);"
|
||||
update-with-bindings ;
|
||||
|
||||
: create-bootstrap-arcs ( -- )
|
||||
has-type-relation has-type-relation relation-type create-arc drop
|
||||
has-type-relation semantic-db-context context-type create-arc drop
|
||||
has-context-relation has-type-relation semantic-db-context create-arc drop
|
||||
has-type-relation has-context-relation relation-type create-arc drop
|
||||
has-context-relation has-context-relation semantic-db-context create-arc drop ;
|
||||
|
||||
: init-semantic-db ( -- )
|
||||
create-node-table create-arc-table create-bootstrap-nodes create-bootstrap-arcs ;
|
||||
|
||||
: node-content ( id -- content )
|
||||
1array "select content from nodes where id = ?" [ 0 column-text ] select-with-bindings 1result ;
|
||||
|
||||
: node-arcs ( node-id -- arcs )
|
||||
1array "select id, relation, subject, object from arcs where subject = ?1 or object = ?1;"
|
||||
[ 4 collect-int-columns ] select-with-bindings ;
|
||||
|
||||
: node-subject-arcs ( node-id -- arcs )
|
||||
1array "select object, relation from arcs where subject = ?;"
|
||||
[ 2 collect-int-columns ] select-with-bindings ;
|
||||
|
||||
: node-object-arcs ( node-id -- arcs )
|
||||
1array "select subject, relation from arcs where object = ?;"
|
||||
[ 2 collect-int-columns ] select-with-bindings ;
|
||||
|
||||
: relation-subject-objects ( relation subject -- objects )
|
||||
2array "select object from arcs where relation = ? and subject = ?;"
|
||||
[ 0 column-int ] select-with-bindings ;
|
||||
|
||||
: relation-object-subjects ( relation object -- subjects )
|
||||
2array "select subject from arcs where relation = ? and object = ?;"
|
||||
[ 0 column-int ] select-with-bindings ;
|
||||
|
||||
: subject-object-relations ( subject object -- relations )
|
||||
2array "select relation from arcs where subject = ? and object = ?"
|
||||
[ 0 column-int ] select-with-bindings ;
|
||||
|
||||
: type-and-name-node ( type name -- node )
|
||||
has-type-relation 3array
|
||||
"select n.id from arcs a, nodes n where a.subject = n.id and a.object = ? and n.name = ? and a.relation = ?"
|
||||
[ 0 column-int ] select-with-bindings 1result ;
|
||||
|
||||
: create-node-of-type ( type name -- node )
|
||||
create-node [ has-type-relation -rot create-arc drop ] keep ;
|
||||
|
||||
: ensure-node-of-type ( type name -- node )
|
||||
2dup type-and-name-node [ 2nip ] [ create-node-of-type ] if* ;
|
||||
|
||||
: type-and-name-in-context-node ( context type name -- node )
|
||||
<query>
|
||||
"id" "n" [ 0 column-int ] add-field
|
||||
"nodes n" add-table
|
||||
"n.name = :name" add-condition
|
||||
":name" add-arg
|
||||
"arcs a" add-table
|
||||
"a.relation = :has_type" add-condition
|
||||
has-type-relation ":has_type" add-arg
|
||||
"a.subject = n.id" add-condition
|
||||
"a.object = :type" add-condition
|
||||
":type" add-arg
|
||||
"arcs b" add-table
|
||||
"b.subject = a.relation" add-condition
|
||||
"b.relation = :has_context" add-condition
|
||||
has-context-relation ":has_context" add-arg
|
||||
"b.object = :context" add-condition
|
||||
":context" add-arg
|
||||
get-results 1result ;
|
||||
|
||||
|
||||
! ideas for an api:
|
||||
! this would work something like jquery, where arcs can be selected according
|
||||
! to parameters, and the contents of nodes and arcs are retrieved on demand, or
|
||||
! at the program's convenience. It may be better to do this as a query language.
|
||||
! TUPLE: node id content ;
|
||||
! : node-text ( node -- text )
|
||||
! dup node-content [
|
||||
! nip
|
||||
! ] [
|
||||
! node-id ! now get content from database, save it in node-content, and return it
|
||||
! ] if* ;
|
||||
! TUPLE: arc id relation subject object ;
|
||||
!
|
||||
! TUPLE: arcs ids relation subject object ;
|
||||
Loading…
Reference in New Issue