steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

semantic-db: pass around node objects instead of ids

db4
Alex Chapman 2008-04-01 12:07:02 +11:00
parent 7b3a9e43b6
commit 5dd354333f
2 changed files with 169 additions and 103 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
extra/semantic-db/semantic-db-tests.factor
View File

@ -1,7 +1,6 @@
USING: accessors arrays continuations db db.sqlite db.tuples io.files USING: accessors arrays continuations db db.sqlite db.tuples io.files
kernel math namespaces semantic-db kernel math namespaces semantic-db sequences sorting tools.test
tools.walker ;
sequences sorting tools.test tools.walker ;
IN: semantic-db.tests IN: semantic-db.tests
SYMBOL: context SYMBOL: context
@ -14,32 +13,34 @@ delete-db
test-db [ test-db [
node create-table arc create-table node create-table arc create-table
[ 1 ] [ "first node" create-node ] unit-test [ 1 ] [ "first node" create-node id>> ] unit-test
[ 2 ] [ "second node" create-node ] unit-test [ 2 ] [ "second node" create-node id>> ] unit-test
[ 3 ] [ "third node" create-node ] unit-test [ 3 ] [ "third node" create-node id>> ] unit-test
[ 4 ] [ f create-node ] unit-test [ 4 ] [ f create-node id>> ] unit-test
[ 5 ] [ 1 2 3 create-arc ] unit-test [ ] [ 1 f <node> 2 f <node> 3 f <node> create-arc ] unit-test
] with-db delete-db ] with-db delete-db
test-db [ test-db [
init-semantic-db init-semantic-db
"test content" create-context context set "test content" create-context context set
[ 4 ] [ context get ] unit-test [ T{ node f 3 "test content" } ] [ context get ] unit-test
[ 5 ] [ "is test content" context get create-relation ] unit-test [ T{ node f 4 "is test content" } ] [ "is test content" context get create-relation ] unit-test
[ 5 ] [ "is test content" context get get-relation ] unit-test [ T{ node f 4 "is test content" } ] [ "is test content" context get get-relation ] unit-test
[ 5 ] [ "is test content" context get relation-id ] unit-test [ T{ node f 4 "is test content" } ] [ "is test content" context get ensure-relation ] unit-test
[ 7 ] [ "has parent" context get relation-id ] unit-test [ T{ node f 5 "has parent" } ] [ "has parent" context get ensure-relation ] unit-test
[ 7 ] [ "has parent" context get relation-id ] unit-test [ T{ node f 5 "has parent" } ] [ "has parent" context get ensure-relation ] unit-test
[ "has parent" ] [ "has parent" context get relation-id node-content ] unit-test [ "has parent" ] [ "has parent" context get ensure-relation node-content ] unit-test
[ "test content" ] [ context get node-content ] unit-test [ "test content" ] [ context get node-content ] unit-test
] with-db delete-db ] with-db delete-db
! "test1" f f f f f <relation-definition> define-relation ! "test1" "test1-relation-id-word" f f f f <relation-definition> define-relation
! "test2" t t t t t <relation-definition> define-relation ! "test2" t t t t t <relation-definition> define-relation
RELATION: test RELATION: test3
test-db [ test-db [
init-semantic-db init-semantic-db
[ 5 ] [ test-relation ] unit-test ! [ T{ node f 3 "test1" } ] [ test1-relation-id-word ] unit-test
! [ T{ node f 4 "test2" } ] [ test2-relation ] unit-test
[ T{ node f 4 "test3" } ] [ test3-relation ] unit-test
] with-db delete-db ] with-db delete-db
! test hierarchy ! test hierarchy
@ -52,12 +53,14 @@ test-db [
"fran" create-node "fran" set "fran" create-node "fran" set
"charlie" create-node "charlie" set "charlie" create-node "charlie" set
"gertrude" create-node "gertrude" set "gertrude" create-node "gertrude" set
[ t ] [ "bob" get "adam" get has-parent integer? ] unit-test [ ] [ "bob" get "adam" get has-parent ] unit-test
{ { "bob" "eve" } { "fran" "eve" } { "gertrude" "bob" } { "fran" "bob" } { "charlie" "fran" } } [ first2 [ get ] 2apply has-parent drop ] each { { "bob" "eve" } { "fran" "eve" } { "gertrude" "bob" } { "fran" "bob" } { "charlie" "fran" } } [ first2 [ get ] 2apply has-parent ] each
[ { "bob" "fran" } ] [ "eve" get has-parent-relation children [ node-content ] map ] unit-test [ { "bob" "fran" } ] [ "eve" get has-parent-relation children [ node-content ] map ] unit-test
[ { "adam" "eve" } ] [ "bob" get has-parent-relation parents [ node-content ] map ] unit-test [ { "adam" "eve" } ] [ "bob" get has-parent-relation parents [ node-content ] map ] unit-test
[ "fran" { "charlie" } ] [ "fran" get has-parent-relation get-node-hierarchy dup tree-id node-content swap tree-children [ tree-id node-content ] map ] unit-test [ "fran" { "charlie" } ] [ "fran" get has-parent-relation get-node-hierarchy dup node>> node-content swap children>> [ node>> node-content ] map ] unit-test
[ { "adam" "eve" } ] [ "charlie" get has-parent-relation get-root-nodes [ node-content ] map natural-sort >array ] unit-test [ { "adam" "eve" } ] [ "charlie" get has-parent-relation get-root-nodes [ node-content ] map natural-sort >array ] unit-test
[ { } ] [ "charlie" get dup "fran" get !has-parent has-parent-relation parents [ node-content ] map ] unit-test [ { } ] [ "charlie" get dup "fran" get !has-parent has-parent-relation parents [ node-content ] map ] unit-test
[ { "adam" "eve" } ] [ has-parent-relation ultimate-objects node-results [ node-content ] map ] unit-test
[ { "fran" "gertrude" } ] [ has-parent-relation ultimate-subjects node-results [ node-content ] map ] unit-test
] with-db delete-db ] with-db delete-db

227
extra/semantic-db/semantic-db.factor
View File

@ -1,14 +1,13 @@
! Copyright (C) 2008 Alex Chapman ! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators combinators.cleave continuations db db.tuples db.types db.sqlite hashtables kernel math math.parser namespaces new-slots parser sequences sequences.deep sequences.lib strings words ; USING: accessors arrays combinators combinators.cleave combinators.lib
continuations db db.tuples db.types db.sqlite hashtables kernel math
math.parser namespaces parser sequences sequences.deep
sequences.lib strings words ;
IN: semantic-db IN: semantic-db
TUPLE: node id content ; TUPLE: node id content ;
: <node> ( content -- node ) C: <node> node
node construct-empty swap >>content ;
: <id-node> ( id -- node )
node construct-empty swap >>id ;
node "node" node "node"
{ {
@ -16,15 +15,14 @@ node "node"
{ "content" "content" TEXT } { "content" "content" TEXT }
} define-persistent } define-persistent
: delete-node ( node-id -- ) : delete-node ( node -- ) delete-tuple ;
<id-node> delete-tuple ; : create-node ( content -- node ) f swap <node> dup insert-tuple ;
: load-node ( id -- node ) f <node> select-tuple ;
: create-node ( str -- node-id ) : node-content ( node -- content )
<node> dup insert-tuple id>> ; dup content>> [ nip ] [ select-tuple content>> ] if* ;
: node-content ( id -- str )
<id-node> select-tuple content>> ;
! TODO: get rid of arc id and write our own sql
TUPLE: arc id subject object relation ; TUPLE: arc id subject object relation ;
: <arc> ( subject object relation -- arc ) : <arc> ( subject object relation -- arc )
@ -33,42 +31,50 @@ TUPLE: arc id subject object relation ;
: <id-arc> ( id -- arc ) : <id-arc> ( id -- arc )
arc construct-empty swap >>id ; arc construct-empty swap >>id ;
: insert-arc ( arc -- ) : delete-arc ( arc -- ) delete-tuple ;
f <node> dup insert-tuple id>> >>id insert-tuple ;
: delete-arc ( arc-id -- ) : create-arc ( subject object relation -- )
dup delete-node <id-arc> delete-tuple ; [ id>> ] 3apply <arc> insert-tuple ;
: create-arc ( subject object relation -- arc-id ) : nodes>arc ( subject object relation -- arc )
<arc> dup insert-arc id>> ; [ [ id>> ] [ f ] if* ] 3apply <arc> ;
: has-arc? ( subject object relation -- ? )
<arc> select-tuples length 0 > ;
: select-arcs ( subject object relation -- arcs ) : select-arcs ( subject object relation -- arcs )
<arc> select-tuples ; nodes>arc select-tuples ;
: select-arc-ids ( subject object relation -- arc-ids ) : has-arc? ( subject object relation -- ? )
select-arcs [ id>> ] map ; select-arcs length 0 > ;
: select-arc-subjects ( subject object relation -- subject-ids ) : select-arc-subjects ( subject object relation -- subjects )
select-arcs [ subject>> ] map ; select-arcs [ subject>> f <node> ] map ;
: select-subjects ( object relation -- subject-ids ) : select-arc-subject ( subject object relation -- subject )
select-arcs ?first [ subject>> f <node> ] [ f ] if* ;
: select-subjects ( object relation -- subjects )
f -rot select-arc-subjects ; f -rot select-arc-subjects ;
: select-arc-objects ( subject object relation -- object-ids ) : select-subject ( object relation -- subject )
select-arcs [ object>> ] map ; f -rot select-arc-subject ;
: select-objects ( subject relation -- object-ids ) : select-arc-objects ( subject object relation -- objects )
select-arcs [ object>> f <node> ] map ;
: select-arc-object ( subject object relation -- object )
select-arcs ?first [ object>> f <node> ] [ f ] if* ;
: select-objects ( subject relation -- objects )
f swap select-arc-objects ; f swap select-arc-objects ;
: select-object ( subject relation -- object )
f swap select-arc-object ;
: delete-arcs ( subject object relation -- ) : delete-arcs ( subject object relation -- )
select-arcs [ id>> delete-arc ] each ; select-arcs [ delete-arc ] each ;
arc "arc" arc "arc"
{ {
{ "id" "id" INTEGER +assigned-id+ } ! foreign key to node table? { "id" "id" +native-id+ +autoincrement+ }
{ "relation" "relation" INTEGER +not-null+ } { "relation" "relation" INTEGER +not-null+ }
{ "subject" "subject" INTEGER +not-null+ } { "subject" "subject" INTEGER +not-null+ }
{ "object" "object" INTEGER +not-null+ } { "object" "object" INTEGER +not-null+ }
@ -78,66 +84,99 @@ arc "arc"
"semantic-db" create-node drop "semantic-db" create-node drop
"has-context" create-node drop ; "has-context" create-node drop ;
: semantic-db-context 1 ; : semantic-db-context T{ node f 1 "semantic-db" } ;
: has-context-relation 2 ; : has-context-relation T{ node f 2 "has-context" } ;
: create-bootstrap-arcs ( -- ) : create-bootstrap-arcs ( -- )
has-context-relation semantic-db-context has-context-relation create-arc drop ; has-context-relation semantic-db-context has-context-relation create-arc ;
: init-semantic-db ( -- ) : init-semantic-db ( -- )
node create-table node create-table arc create-table
arc create-table
create-bootstrap-nodes create-bootstrap-arcs ; create-bootstrap-nodes create-bootstrap-arcs ;
: param ( value key type -- param ) : param ( value key type -- param ) swapd 3array ;
swapd 3array ;
: single-int-results ( bindings sql -- array ) ! db utilities
f f <simple-statement> [ do-bound-query ] with-disposal : results ( bindings sql -- array )
[ first string>number ] map ; f f <simple-statement> [ do-bound-query ] with-disposal ;
: ensure1 ( x quot1 quot2 -- y ) : node-result ( result -- node )
#! quot1 ( x -- y/f ) tries to find an existing y dup first string>number swap second <node> ;
#! quot2 ( x -- y ) creates a new y if quot1 returns f
>r dupd call [ nip ] r> if* ;
: ensure2 ( x y quot1 quot2 -- z ) : ?1node-result ( results -- node )
#! quot1 ( x y -- z/f ) tries to find an existing z ?first [ node-result ] [ f ] if* ;
#! quot2 ( x y -- z ) creates a new z if quot1 returns f
>r >r 2dup r> call [ 2nip ] r> if* ; : node-results ( results -- nodes )
[ node-result ] map ;
: subjects-with-cor ( content object relation -- sql-results )
[ id>> ] 2apply
[
":relation" INTEGER param ,
":object" INTEGER param ,
":content" TEXT param ,
] { } make
"select n.id, n.content from node n, arc a where n.content = :content and n.id = a.subject and a.relation = :relation and a.object = :object" results ;
: objects-with-csr ( content subject relation -- sql-results )
[ id>> ] 2apply
[
":relation" INTEGER param ,
":subject" INTEGER param ,
":content" TEXT param ,
] { } make
"select n.id, n.content from node n, arc a where n.content = :content and n.id = a.object and a.relation = :relation and a.subject = :subject" results ;
: (with-relation) ( content relation -- bindings sql )
id>> [ ":relation" INTEGER param , ":content" TEXT param , ] { } make
"select distinct n.id, n.content from node n, arc a where n.content = :content and a.relation = :relation" ;
: subjects-with-relation ( content relation -- sql-results )
(with-relation) " and a.object = n.id" append results ;
: objects-with-relation ( content relation -- sql-results )
(with-relation) " and a.subject = n.id" append results ;
: (ultimate) ( relation b a -- sql-results )
[
"select distinct n.id, n.content from node n, arc a where a.relation = :relation and n.id = a." % % " and n.id not in (select b." % % " from arc b where b.relation = :relation)" %
] "" make [ id>> ":relation" INTEGER param 1array ] dip results ;
: ultimate-objects ( relation -- sql-results )
"subject" "object" (ultimate) ;
: ultimate-subjects ( relation -- sql-results )
"object" "subject" (ultimate) ;
! contexts: ! contexts:
! - a node n is a context iff there exists a relation r such that r has context n ! - a node n is a context iff there exists a relation r such that r has context n
: create-context ( context-name -- context-id ) create-node ; : create-context ( context-name -- context ) create-node ;
: get-context ( context-name -- context-id/f ) : get-context ( context-name -- context/f )
[ has-context-relation subjects-with-relation ?1node-result ;
":name" TEXT param ,
has-context-relation ":has_context" INTEGER param ,
] { } make
"select distinct n.id from node n, arc a where n.content = :name and a.relation = :has_context and a.object = n.id"
single-int-results ?first ;
: context-id ( context-name -- context-id ) : ensure-context ( context-name -- context )
[ get-context ] [ create-context ] ensure1 ; dup get-context [
nip
] [
create-context
] if* ;
! relations: ! relations:
! - have a context in context 'semantic-db' ! - have a context in context 'semantic-db'
: create-relation ( relation-name context-id -- relation-id ) : create-relation ( relation-name context -- relation )
[ create-node dup ] dip has-context-relation create-arc drop ; [ create-node dup ] dip has-context-relation create-arc ;
: get-relation ( relation-name context-id -- relation-id/f ) : get-relation ( relation-name context -- relation/f )
[ has-context-relation subjects-with-cor ?1node-result ;
":context" INTEGER param ,
":name" TEXT param ,
has-context-relation ":has_context" INTEGER param ,
] { } make
"select n.id from node n, arc a where n.content = :name and n.id = a.subject and a.relation = :has_context and a.object = :context"
single-int-results ?first ;
: relation-id ( relation-name context-id -- relation-id ) : ensure-relation ( relation-name context -- relation )
[ get-relation ] [ create-relation ] ensure2 ; 2dup get-relation [
2nip
] [
create-relation
] if* ;
TUPLE: relation-definition relate id-word unrelate related? subjects objects ; TUPLE: relation-definition relate id-word unrelate related? subjects objects ;
C: <relation-definition> relation-definition C: <relation-definition> relation-definition
@ -181,7 +220,7 @@ C: <relation-definition> relation-definition
: define-id-word ( relation-definition id-word -- ) : define-id-word ( relation-definition id-word -- )
[ relate>> ] dip tuck word-vocabulary [ relate>> ] dip tuck word-vocabulary
[ context-id relation-id ] 2curry define ; [ ensure-context ensure-relation ] 2curry define ;
: create-id-word ( relation-definition -- id-word ) : create-id-word ( relation-definition -- id-word )
dup id-word>> "id-word" choose-word-name create-in ; dup id-word>> "id-word" choose-word-name create-in ;
@ -195,22 +234,46 @@ PRIVATE>
scan t t t t t <relation-definition> define-relation ; parsing scan t t t t t <relation-definition> define-relation ; parsing
! hierarchy ! hierarchy
TUPLE: tree id children ; TUPLE: node-tree node children ;
C: <tree> tree C: <node-tree> node-tree
: children ( node-id has-parent-relation -- children ) select-subjects ; : children ( node has-parent-relation -- children ) select-subjects ;
: parents ( node-id has-parent-relation -- parents ) select-objects ; : parents ( node has-parent-relation -- parents ) select-objects ;
: get-node-hierarchy ( node-id has-parent-relation -- tree ) : get-node-tree ( node child-selector -- node-tree )
2dup children >r [ get-node-hierarchy ] curry r> swap map <tree> ; 2dup call >r [ get-node-tree ] curry r> swap map <node-tree> ;
: (get-root-nodes) ( node-id has-parent-relation -- root-nodes/node-id ) ! : get-node-tree ( node has-parent-relation -- node-tree )
! 2dup children >r [ get-node-tree ] curry r> swap map <node-tree> ;
: get-node-tree-s ( node has-parent-relation -- tree )
[ select-subjects ] curry get-node-tree ;
: get-node-tree-o ( node has-child-relation -- tree )
[ select-objects ] curry get-node-tree ;
: (get-node-chain) ( node next-selector seq -- seq )
pick [
over push >r [ call ] keep r> (get-node-chain)
] [
2nip
] if* ;
: get-node-chain ( node next-selector -- seq )
V{ } clone (get-node-chain) ;
: get-node-chain-o ( node relation -- seq )
[ select-object ] curry get-node-chain ;
: get-node-chain-s ( node relation -- seq )
[ select-subject ] curry get-node-chain ;
: (get-root-nodes) ( node has-parent-relation -- root-nodes/node )
2dup parents dup empty? [ 2dup parents dup empty? [
2drop 2drop
] [ ] [
>r nip [ (get-root-nodes) ] curry r> swap map >r nip [ (get-root-nodes) ] curry r> swap map
] if ; ] if ;
: get-root-nodes ( node-id has-parent-relation -- root-nodes ) : get-root-nodes ( node has-parent-relation -- root-nodes )
(get-root-nodes) flatten prune ; (get-root-nodes) flatten prune ;