semantic-db: I like the new stuff better than the old stuff
Alex Chapman
parent
0c2ceed71b
commit
6bb2a46acb
extra/semantic-db
context
hierarchy
relations
type
|
|
@ -1,19 +1,16 @@
|
|||
! Copyright (C) 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel semantic-db semantic-db.type ;
|
||||
USING: kernel namespaces semantic-db ;
|
||||
IN: semantic-db.context
|
||||
|
||||
! contexts:
|
||||
! - have type 'context' in context 'semantic-db'
|
||||
: create-context* ( context-name -- context-id ) create-node* ;
|
||||
: create-context ( context-name -- ) create-context* drop ;
|
||||
|
||||
: current-context ( -- context-id )
|
||||
\ current-context get ;
|
||||
: context ( -- context-id )
|
||||
\ context get ;
|
||||
|
||||
: set-current-context ( context-id -- )
|
||||
\ current-context set ;
|
||||
: set-context ( context-id -- )
|
||||
\ context set ;
|
||||
|
||||
: context-id ( name -- context-id )
|
||||
context-type swap ensure-node-of-type ;
|
||||
|
||||
: with-context ( name quot -- )
|
||||
swap context-id [ set-current-context ] curry swap compose with-scope ;
|
||||
: with-context ( context-id quot -- )
|
||||
>r \ context r> with-variable ;
|
||||
|
|
|
|||
|
|
@ -1,38 +1,44 @@
|
|||
! Copyright (C) 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel new-slots semantic-db semantic-db.relations sequences ;
|
||||
USING: accessors db.tuples kernel new-slots semantic-db semantic-db.relations sequences sequences.deep ;
|
||||
IN: semantic-db.hierarchy
|
||||
|
||||
TUPLE: tree id children ;
|
||||
C: <tree> tree
|
||||
|
||||
! TODO: don't use context here. Hierarchies should be created within
|
||||
! arbitrary contexts.
|
||||
: hierarchy-context ( -- context-id )
|
||||
"hierarchy" context-id ;
|
||||
|
||||
: has-parent-relation ( -- relation-id )
|
||||
hierarchy-context "has parent" relation-id ;
|
||||
"has parent" relation-id ;
|
||||
|
||||
: parent-of ( parent child -- arc-id )
|
||||
has-parent-relation spin create-arc ;
|
||||
: parent-child* ( parent child -- arc-id )
|
||||
has-parent-relation spin create-arc* ;
|
||||
|
||||
: select-parents ( child -- parents )
|
||||
: parent-child ( parent child -- )
|
||||
parent-child* drop ;
|
||||
|
||||
: un-parent-child ( parent child -- )
|
||||
has-parent-relation -rot <arc> select-tuples [ id>> delete-arc ] each ;
|
||||
|
||||
: ensure-parent ( child parent -- )
|
||||
! TODO
|
||||
;
|
||||
: child-arcs ( node-id -- child-arcs )
|
||||
has-parent-relation f rot <arc> select-tuples ;
|
||||
|
||||
: find-children ( node-id -- children )
|
||||
! find arcs with:
|
||||
! relation = has-parent-relation
|
||||
! object = node-id
|
||||
! then load the subjects either as nodes or subtrees
|
||||
":node_id" INTEGER param
|
||||
has-parent-relation ":has_parent" INTEGER param 2array
|
||||
"select a.subject from arc a where relation = :has_parent and object = :node_id"
|
||||
single-int-results ;
|
||||
: children ( node-id -- children )
|
||||
child-arcs [ subject>> ] map ;
|
||||
|
||||
: parent-arcs ( node-id -- parent-arcs )
|
||||
has-parent-relation swap f <arc> select-tuples ;
|
||||
|
||||
: parents ( node-id -- parents )
|
||||
parent-arcs [ object>> ] map ;
|
||||
|
||||
: get-node-hierarchy ( node-id -- tree )
|
||||
dup find-children <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 ;
|
||||
|
|
|
|||
|
|
@ -1,27 +1,26 @@
|
|||
! Copyright (C) 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel semantic-db semantic-db.context semantic-db.type ;
|
||||
USING: db.types kernel namespaces semantic-db semantic-db.context
|
||||
sequences.lib ;
|
||||
IN: semantic-db.relations
|
||||
|
||||
! relations:
|
||||
! - have type 'relation' in context 'semantic-db'
|
||||
! - have a context in context 'semantic-db'
|
||||
|
||||
: create-relation ( context-id relation-name -- relation-id )
|
||||
relation-type swap ensure-node-of-type
|
||||
tuck has-context-relation spin create-arc ;
|
||||
: create-relation* ( context-id relation-name -- relation-id )
|
||||
create-node* tuck has-context-relation spin create-arc ;
|
||||
|
||||
: select-relation ( context-id relation-name -- relation-id/f )
|
||||
: create-relation ( context-id relation-name -- )
|
||||
create-relation* drop ;
|
||||
|
||||
: get-relation ( context-id relation-name -- relation-id/f )
|
||||
[
|
||||
":name" TEXT param ,
|
||||
has-type-relation ":has_type" INTEGER param ,
|
||||
relation-type ":relation_type" INTEGER param ,
|
||||
":context" INTEGER param ,
|
||||
has-context-relation ":has_context" INTEGER param ,
|
||||
] { } make
|
||||
"select n.id from node n, arc a, arc b where n.content = :name and n.id = a.subject and a.relation = :has_type and a.object = :relation_type and n.id = b.subject and b.relation = :has_context and b.object = :context"
|
||||
single-int-results ;
|
||||
"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 ( context-id relation-name -- relation-id )
|
||||
[ select-relation ] [ create-relation ] ensure2 ;
|
||||
! 2dup select-relation [ 2nip ] [ create-relation ] if* ;
|
||||
: relation-id ( relation-name -- relation-id )
|
||||
context swap [ get-relation ] [ create-relation* ] ensure2 ;
|
||||
|
|
|
|||
|
|
@ -1,26 +1,58 @@
|
|||
USING: accessors arrays db db.sqlite db.tuples kernel math semantic-db semantic-db.type sequences tools.test tools.walker ;
|
||||
IN: temporary
|
||||
USING: accessors arrays db db.sqlite db.tuples kernel math namespaces
|
||||
semantic-db semantic-db.context semantic-db.hierarchy semantic-db.relations
|
||||
sequences tools.test tools.walker ;
|
||||
IN: vocab.tests
|
||||
|
||||
[
|
||||
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-tmp-sqlite
|
||||
|
||||
[
|
||||
init-semantic-db
|
||||
type-type 1array [ "type" ensure-type ] unit-test
|
||||
[ { 1 2 3 } ] [ type-type select-nodes-of-type ] unit-test
|
||||
[ 1 ] [ type-type select-node-of-type ] unit-test
|
||||
[ t ] [ "content" ensure-type integer? ] unit-test
|
||||
[ t ] [ "content" ensure-type "content" ensure-type = ] unit-test
|
||||
[ t ] [ "content" ensure-type "first content" create-node-of-type integer? ] unit-test
|
||||
[ t ] [ "content" ensure-type select-node-of-type integer? ] unit-test
|
||||
[ t ] [ "content" ensure-type "first content" select-node-of-type-with-content integer? ] unit-test
|
||||
[ t ] [ "content" ensure-type "first content" ensure-node-of-type integer? ] unit-test
|
||||
[ t ] [ "content" ensure-type "second content" ensure-node-of-type integer? ] unit-test
|
||||
[ 2 ] [ "content" ensure-type select-nodes-of-type length ] unit-test
|
||||
"test content" create-context* [
|
||||
[ 4 ] [ context ] unit-test
|
||||
[ 5 ] [ context "is test content" create-relation* ] unit-test
|
||||
[ 5 ] [ context "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
|
||||
[ "test content" ] [ context node-content ] unit-test
|
||||
] with-context
|
||||
! type-type 1array [ "type" ensure-type ] unit-test
|
||||
! [ { 1 2 3 } ] [ type-type select-nodes-of-type ] unit-test
|
||||
! [ 1 ] [ type-type select-node-of-type ] unit-test
|
||||
! [ t ] [ "content" ensure-type integer? ] unit-test
|
||||
! [ t ] [ "content" ensure-type "content" ensure-type = ] unit-test
|
||||
! [ t ] [ "content" ensure-type "first content" create-node-of-type integer? ] unit-test
|
||||
! [ t ] [ "content" ensure-type select-node-of-type integer? ] unit-test
|
||||
! [ t ] [ "content" ensure-type "first content" select-node-of-type-with-content integer? ] unit-test
|
||||
! [ t ] [ "content" ensure-type "first content" ensure-node-of-type integer? ] unit-test
|
||||
! [ t ] [ "content" ensure-type "second content" ensure-node-of-type integer? ] unit-test
|
||||
! [ 2 ] [ "content" ensure-type select-nodes-of-type length ] unit-test
|
||||
] with-tmp-sqlite
|
||||
|
||||
! test hierarchy
|
||||
[
|
||||
init-semantic-db
|
||||
"family tree" create-context* [
|
||||
"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" } { "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 ] unit-test
|
||||
[ { } ] [ "fran" get "charlie" get tuck un-parent-child parents ] unit-test
|
||||
] with-context
|
||||
] with-tmp-sqlite
|
||||
|
|
|
|||
|
|
@ -7,6 +7,9 @@ TUPLE: node id content ;
|
|||
: <node> ( content -- node )
|
||||
node construct-empty swap >>content ;
|
||||
|
||||
: <id-node> ( id -- node )
|
||||
node construct-empty swap >>id ;
|
||||
|
||||
node "node"
|
||||
{
|
||||
{ "id" "id" +native-id+ +autoincrement+ }
|
||||
|
|
@ -16,14 +19,38 @@ node "node"
|
|||
: create-node-table ( -- )
|
||||
node create-table ;
|
||||
|
||||
: create-node ( content -- id )
|
||||
: delete-node ( node-id -- )
|
||||
<id-node> delete-tuple ;
|
||||
|
||||
: 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 ;
|
||||
|
||||
: <arc> ( relation subject object -- arc )
|
||||
arc construct-empty swap >>object swap >>subject swap >>relation ;
|
||||
|
||||
: <id-arc> ( id -- arc )
|
||||
arc construct-empty swap >>id ;
|
||||
|
||||
: insert-arc ( arc -- )
|
||||
f <node> dup insert-tuple id>> >>id insert-tuple ;
|
||||
|
||||
: delete-arc ( arc-id -- )
|
||||
dup delete-node <id-arc> delete-tuple ;
|
||||
|
||||
: create-arc* ( relation subject object -- 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?
|
||||
|
|
@ -35,47 +62,15 @@ arc "arc"
|
|||
: create-arc-table ( -- )
|
||||
arc create-table ;
|
||||
|
||||
: insert-arc ( arc -- )
|
||||
f <node> dup insert-tuple id>> >>id insert-tuple ;
|
||||
|
||||
: delete-arc ( arc -- )
|
||||
dup delete-tuple delegate delete-tuple ;
|
||||
|
||||
: create-arc ( relation subject object -- id )
|
||||
<arc> dup insert-arc id>> ;
|
||||
|
||||
: create-bootstrap-nodes ( -- )
|
||||
{ "context" "type" "relation" "has type" "semantic-db" "has context" }
|
||||
[ create-node drop ] each ;
|
||||
"semantic-db" create-node
|
||||
"has context" create-node ;
|
||||
|
||||
! TODO: maybe put these in a 'special nodes' table
|
||||
: context-type 1 ; inline
|
||||
: type-type 2 ; inline
|
||||
: relation-type 3 ; inline
|
||||
: has-type-relation 4 ; inline
|
||||
: semantic-db-context 5 ; inline
|
||||
: has-context-relation 6 ; inline
|
||||
|
||||
: has-semantic-db-context ( id -- )
|
||||
has-context-relation swap semantic-db-context create-arc drop ;
|
||||
|
||||
: has-type-in-semantic-db ( subject type -- )
|
||||
has-type-relation -rot create-arc drop ;
|
||||
: semantic-db-context 1 ;
|
||||
: has-context-relation 2 ;
|
||||
|
||||
: create-bootstrap-arcs ( -- )
|
||||
! give everything a type
|
||||
context-type type-type has-type-in-semantic-db
|
||||
type-type type-type has-type-in-semantic-db
|
||||
relation-type type-type has-type-in-semantic-db
|
||||
has-type-relation relation-type has-type-in-semantic-db
|
||||
semantic-db-context context-type has-type-in-semantic-db
|
||||
has-context-relation relation-type has-type-in-semantic-db
|
||||
! give relations and types the semantic-db context
|
||||
context-type has-semantic-db-context
|
||||
type-type has-semantic-db-context
|
||||
relation-type has-semantic-db-context
|
||||
has-type-relation has-semantic-db-context
|
||||
has-context-relation has-semantic-db-context ;
|
||||
has-context-relation has-context-relation semantic-db-context create-arc ;
|
||||
|
||||
: init-semantic-db ( -- )
|
||||
create-node-table create-arc-table create-bootstrap-nodes create-bootstrap-arcs ;
|
||||
|
|
|
|||
|
|
@ -8,10 +8,10 @@ IN: semantic-db.type
|
|||
! - have a context in context 'semantic-db'
|
||||
|
||||
: assign-type ( type nid -- arc-id )
|
||||
has-type-relation spin create-arc ;
|
||||
has-type-relation spin arc-id ;
|
||||
|
||||
: create-node-of-type ( type content -- node-id )
|
||||
create-node [ assign-type drop ] keep ;
|
||||
node-id [ assign-type drop ] keep ;
|
||||
|
||||
: select-nodes-of-type ( type -- node-ids )
|
||||
":type" INTEGER param
|
||||
|
|
@ -33,7 +33,7 @@ IN: semantic-db.type
|
|||
single-int-results ;
|
||||
|
||||
: select-node-of-type-with-content ( type content -- node-id/f )
|
||||
select-nodes-of-type-with-content 1result ;
|
||||
select-nodes-of-type-with-content ?first ;
|
||||
|
||||
: ensure-node-of-type ( type content -- node-id )
|
||||
[ select-node-of-type-with-content ] [ create-node-of-type ] ensure2 ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue