semantic-db: move everything into one vocab
Alex Chapman
parent
0ee7ced180
commit
c90c0025c7
|
|
@ -1,10 +0,0 @@
|
|||
! Copyright (C) 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel namespaces semantic-db ;
|
||||
IN: semantic-db.context
|
||||
|
||||
: create-context* ( context-name -- context-id ) create-node* ;
|
||||
: create-context ( context-name -- ) create-context* drop ;
|
||||
|
||||
SYMBOL: context
|
||||
|
||||
|
|
@ -1,44 +0,0 @@
|
|||
! Copyright (C) 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors db.tuples hashtables kernel namespaces new-slots
|
||||
semantic-db semantic-db.relations sequences sequences.deep ;
|
||||
IN: semantic-db.hierarchy
|
||||
|
||||
TUPLE: tree id children ;
|
||||
C: <tree> tree
|
||||
|
||||
SYMBOL: has-parent-relation
|
||||
|
||||
: parent-child* ( parent child -- arc-id )
|
||||
has-parent-relation get spin create-arc* ;
|
||||
|
||||
: parent-child ( parent child -- )
|
||||
parent-child* drop ;
|
||||
|
||||
: un-parent-child ( parent child -- )
|
||||
has-parent-relation get spin <arc> select-tuples [ id>> delete-arc ] each ;
|
||||
|
||||
: child-arcs ( node-id -- child-arcs )
|
||||
has-parent-relation get f rot <arc> select-tuples ;
|
||||
|
||||
: children ( node-id -- children )
|
||||
child-arcs [ subject>> ] map ;
|
||||
|
||||
: parent-arcs ( node-id -- parent-arcs )
|
||||
has-parent-relation get swap f <arc> select-tuples ;
|
||||
|
||||
: parents ( node-id -- parents )
|
||||
parent-arcs [ object>> ] map ;
|
||||
|
||||
: get-node-hierarchy ( node-id -- tree )
|
||||
dup children [ get-node-hierarchy ] map <tree> ;
|
||||
|
||||
: (get-root-nodes) ( node-id -- root-nodes/node-id )
|
||||
dup parents dup empty? [
|
||||
drop
|
||||
] [
|
||||
nip [ (get-root-nodes) ] map
|
||||
] if ;
|
||||
|
||||
: get-root-nodes ( node-id -- root-nodes )
|
||||
(get-root-nodes) flatten prune ;
|
||||
|
|
@ -1,6 +0,0 @@
|
|||
! Copyright (C) 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel new-slots semantic-db semantic-db.relations ;
|
||||
IN: semantic-db.membership
|
||||
|
||||
|
||||
|
|
@ -1,26 +0,0 @@
|
|||
! Copyright (C) 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: db.types kernel namespaces semantic-db semantic-db.context
|
||||
sequences.lib ;
|
||||
IN: semantic-db.relations
|
||||
|
||||
! relations:
|
||||
! - have a context in context 'semantic-db'
|
||||
|
||||
: create-relation* ( context-id relation-name -- relation-id )
|
||||
create-node* tuck has-context-relation spin create-arc ;
|
||||
|
||||
: create-relation ( context-id relation-name -- )
|
||||
create-relation* drop ;
|
||||
|
||||
: get-relation ( context-id relation-name -- relation-id/f )
|
||||
[
|
||||
":name" TEXT param ,
|
||||
":context" INTEGER 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 -- relation-id )
|
||||
context get swap [ get-relation ] [ create-relation* ] ensure2 ;
|
||||
|
|
@ -1,10 +1,12 @@
|
|||
USING: accessors arrays continuations db db.sqlite
|
||||
db.tuples io.files kernel math namespaces semantic-db
|
||||
semantic-db.context semantic-db.hierarchy
|
||||
semantic-db.relations sequences sorting tools.test
|
||||
tools.walker ;
|
||||
USING: accessors arrays continuations db db.sqlite db.tuples io.files
|
||||
kernel math namespaces semantic-db
|
||||
|
||||
sequences sorting tools.test tools.walker ;
|
||||
IN: semantic-db.tests
|
||||
|
||||
SYMBOL: context
|
||||
SYMBOL: has-parent-relation
|
||||
|
||||
: db-path "semantic-db-test.db" temp-file ;
|
||||
: test-db db-path sqlite-db ;
|
||||
: delete-db [ db-path delete-file ] ignore-errors ;
|
||||
|
|
@ -13,25 +15,25 @@ delete-db
|
|||
|
||||
test-db [
|
||||
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
|
||||
[ 5 ] [ 1 2 3 create-arc* ] unit-test
|
||||
[ 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
|
||||
[ 5 ] [ 1 2 3 create-arc ] unit-test
|
||||
] with-db
|
||||
|
||||
delete-db
|
||||
|
||||
test-db [
|
||||
init-semantic-db
|
||||
"test content" create-context* context set
|
||||
"test content" create-context context set
|
||||
[ 4 ] [ context get ] unit-test
|
||||
[ 5 ] [ context get "is test content" create-relation* ] unit-test
|
||||
[ 5 ] [ context get "is test content" get-relation ] unit-test
|
||||
[ 5 ] [ "is test content" relation-id ] unit-test
|
||||
[ 7 ] [ "has parent" relation-id ] unit-test
|
||||
[ 7 ] [ "has parent" relation-id ] unit-test
|
||||
[ "has parent" ] [ "has parent" relation-id node-content ] unit-test
|
||||
[ 5 ] [ "is test content" context get create-relation ] unit-test
|
||||
[ 5 ] [ "is test content" context get get-relation ] unit-test
|
||||
[ 5 ] [ "is test content" context get relation-id ] unit-test
|
||||
[ 7 ] [ "has parent" context get relation-id ] unit-test
|
||||
[ 7 ] [ "has parent" context get relation-id ] unit-test
|
||||
[ "has parent" ] [ "has parent" context get relation-id node-content ] unit-test
|
||||
[ "test content" ] [ context get node-content ] unit-test
|
||||
! type-type 1array [ "type" ensure-type ] unit-test
|
||||
! [ { 1 2 3 } ] [ type-type select-nodes-of-type ] unit-test
|
||||
|
|
@ -51,21 +53,21 @@ delete-db
|
|||
! test hierarchy
|
||||
test-db [
|
||||
init-semantic-db
|
||||
"family tree" create-context* context set
|
||||
"has parent" relation-id has-parent-relation set
|
||||
"adam" create-node* "adam" set
|
||||
"eve" create-node* "eve" set
|
||||
"bob" create-node* "bob" set
|
||||
"fran" create-node* "fran" set
|
||||
"charlie" create-node* "charlie" set
|
||||
"gertrude" create-node* "gertrude" set
|
||||
[ t ] [ "adam" get "bob" get parent-child* integer? ] unit-test
|
||||
{ { "eve" "bob" } { "eve" "fran" } { "bob" "gertrude" } { "bob" "fran" } { "fran" "charlie" } } [ first2 [ get ] 2apply parent-child ] each
|
||||
[ { "bob" "fran" } ] [ "eve" get children [ node-content ] map ] unit-test
|
||||
[ { "adam" "eve" } ] [ "bob" get parents [ node-content ] map ] unit-test
|
||||
[ "fran" { "charlie" } ] [ "fran" get get-node-hierarchy dup tree-id node-content swap tree-children [ tree-id node-content ] map ] unit-test
|
||||
[ { "adam" "eve" } ] [ "charlie" get get-root-nodes [ node-content ] map natural-sort >array ] unit-test
|
||||
[ { } ] [ "fran" get "charlie" get tuck un-parent-child parents [ node-content ] map ] unit-test
|
||||
"family tree" create-context context set
|
||||
"has parent" context get relation-id has-parent-relation set
|
||||
"adam" create-node "adam" set
|
||||
"eve" create-node "eve" set
|
||||
"bob" create-node "bob" set
|
||||
"fran" create-node "fran" set
|
||||
"charlie" create-node "charlie" set
|
||||
"gertrude" create-node "gertrude" set
|
||||
[ t ] [ "adam" get "bob" get has-parent-relation get parent-child integer? ] unit-test
|
||||
{ { "eve" "bob" } { "eve" "fran" } { "bob" "gertrude" } { "bob" "fran" } { "fran" "charlie" } } [ first2 [ get ] 2apply has-parent-relation get parent-child drop ] each
|
||||
[ { "bob" "fran" } ] [ "eve" get has-parent-relation get children [ node-content ] map ] unit-test
|
||||
[ { "adam" "eve" } ] [ "bob" get has-parent-relation get parents [ node-content ] map ] unit-test
|
||||
[ "fran" { "charlie" } ] [ "fran" get has-parent-relation get get-node-hierarchy dup tree-id node-content swap tree-children [ tree-id node-content ] map ] unit-test
|
||||
[ { "adam" "eve" } ] [ "charlie" get has-parent-relation get get-root-nodes [ node-content ] map natural-sort >array ] unit-test
|
||||
[ { } ] [ "fran" get "charlie" get tuck has-parent-relation get un-parent-child has-parent-relation get parents [ node-content ] map ] unit-test
|
||||
] with-db
|
||||
|
||||
delete-db
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays continuations db db.tuples db.types db.sqlite kernel math math.parser new-slots sequences ;
|
||||
USING: accessors arrays continuations db db.tuples db.types db.sqlite hashtables kernel math math.parser namespaces new-slots sequences sequences.deep sequences.lib ;
|
||||
IN: semantic-db
|
||||
|
||||
TUPLE: node id content ;
|
||||
|
|
@ -22,19 +22,16 @@ node "node"
|
|||
: delete-node ( node-id -- )
|
||||
<id-node> delete-tuple ;
|
||||
|
||||
: create-node* ( str -- node-id )
|
||||
: create-node ( str -- node-id )
|
||||
<node> dup insert-tuple id>> ;
|
||||
|
||||
: create-node ( str -- )
|
||||
create-node* drop ;
|
||||
|
||||
: node-content ( id -- str )
|
||||
f <node> swap >>id select-tuple content>> ;
|
||||
|
||||
TUPLE: arc id relation subject object ;
|
||||
TUPLE: arc id subject object relation ;
|
||||
|
||||
: <arc> ( relation subject object -- arc )
|
||||
arc construct-empty swap >>object swap >>subject swap >>relation ;
|
||||
: <arc> ( subject object relation -- arc )
|
||||
arc construct-empty swap >>relation swap >>object swap >>subject ;
|
||||
|
||||
: <id-arc> ( id -- arc )
|
||||
arc construct-empty swap >>id ;
|
||||
|
|
@ -45,12 +42,9 @@ TUPLE: arc id relation subject object ;
|
|||
: delete-arc ( arc-id -- )
|
||||
dup delete-node <id-arc> delete-tuple ;
|
||||
|
||||
: create-arc* ( relation subject object -- arc-id )
|
||||
: create-arc ( subject object relation -- arc-id )
|
||||
<arc> dup insert-arc id>> ;
|
||||
|
||||
: create-arc ( relation subject object -- )
|
||||
create-arc* drop ;
|
||||
|
||||
arc "arc"
|
||||
{
|
||||
{ "id" "id" INTEGER +assigned-id+ } ! foreign key to node table?
|
||||
|
|
@ -59,18 +53,17 @@ arc "arc"
|
|||
{ "object" "object" INTEGER +not-null+ }
|
||||
} define-persistent
|
||||
|
||||
: create-arc-table ( -- )
|
||||
arc create-table ;
|
||||
: create-arc-table ( -- ) arc create-table ;
|
||||
|
||||
: create-bootstrap-nodes ( -- )
|
||||
"semantic-db" create-node
|
||||
"has context" create-node ;
|
||||
"semantic-db" create-node drop
|
||||
"has context" create-node drop ;
|
||||
|
||||
: semantic-db-context 1 ;
|
||||
: has-context-relation 2 ;
|
||||
|
||||
: create-bootstrap-arcs ( -- )
|
||||
has-context-relation has-context-relation semantic-db-context create-arc ;
|
||||
has-context-relation semantic-db-context has-context-relation create-arc drop ;
|
||||
|
||||
: init-semantic-db ( -- )
|
||||
create-node-table create-arc-table create-bootstrap-nodes create-bootstrap-arcs ;
|
||||
|
|
@ -87,3 +80,66 @@ arc "arc"
|
|||
#! quot2 ( x y -- z ) creates a new z if quot1 returns f
|
||||
>r >r 2dup r> call [ 2nip ] r> if* ;
|
||||
|
||||
: create-context ( context-name -- context-id ) create-node ;
|
||||
|
||||
! relations:
|
||||
! - have a context in context 'semantic-db'
|
||||
|
||||
: create-relation ( relation-name context-id -- relation-id )
|
||||
[ create-node dup ] dip has-context-relation create-arc drop ;
|
||||
|
||||
: get-relation ( relation-name context-id -- relation-id/f )
|
||||
[
|
||||
":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 )
|
||||
[ get-relation ] [ create-relation ] ensure2 ;
|
||||
|
||||
! hierarchy
|
||||
TUPLE: tree id children ;
|
||||
C: <tree> tree
|
||||
|
||||
: parent-child ( parent child has-parent-relation -- arc-id ) swapd create-arc ;
|
||||
|
||||
: un-parent-child ( parent child has-parent-relation -- )
|
||||
swapd <arc> select-tuples [ id>> delete-arc ] each ;
|
||||
|
||||
: child-arcs ( parent-id has-parent-relation -- child-arcs )
|
||||
f -rot <arc> select-tuples ;
|
||||
|
||||
: children ( node-id has-parent-relation -- children )
|
||||
child-arcs [ subject>> ] map ;
|
||||
|
||||
: parent-arcs ( node-id has-parent-relation -- parent-arcs )
|
||||
f swap <arc> select-tuples ;
|
||||
|
||||
: parents ( node-id has-parent-relation -- parents )
|
||||
parent-arcs [ object>> ] map ;
|
||||
|
||||
: get-node-hierarchy ( node-id has-parent-relation -- tree )
|
||||
2dup children >r [ get-node-hierarchy ] curry r> swap map <tree> ;
|
||||
|
||||
: (get-root-nodes) ( node-id has-parent-relation -- root-nodes/node-id )
|
||||
2dup parents dup empty? [
|
||||
2drop
|
||||
] [
|
||||
>r nip [ (get-root-nodes) ] curry r> swap map
|
||||
] if ;
|
||||
|
||||
: get-root-nodes ( node-id has-parent-relation -- root-nodes )
|
||||
(get-root-nodes) flatten prune ;
|
||||
|
||||
! sets
|
||||
|
||||
: in-set* ( set member in-set-relation -- arc-id ) swapd create-arc ;
|
||||
|
||||
: in-set? ( set member in-set-relation -- ? )
|
||||
swapd <arc> select-tuples length 0 > ;
|
||||
|
||||
: set-members ( set in-set-relation -- members )
|
||||
f -rot <arc> select-tuples [ id>> ] map ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue