latest semantic-db changes
Alex Chapman
parent
3358672e49
commit
aed24f5657
|
|
@ -1,14 +1,14 @@
|
|||
! Copyright (C) 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: semantic-db ;
|
||||
USING: kernel semantic-db semantic-db.type ;
|
||||
IN: semantic-db.context
|
||||
|
||||
: all-contexts ( -- contexts )
|
||||
has-type-relation context-type relation-object-subjects ;
|
||||
! : all-contexts ( -- contexts )
|
||||
! has-type-relation context-type relation-object-subjects ;
|
||||
!
|
||||
! : context-relations ( context -- relations )
|
||||
! has-context-relation swap relation-object-subjects ;
|
||||
|
||||
: context-relations ( context -- relations )
|
||||
has-context-relation swap relation-object-subjects ;
|
||||
|
||||
: get-context ( name -- context )
|
||||
: ensure-context ( name -- context-id )
|
||||
context-type swap ensure-node-of-type ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,27 @@
|
|||
! Copyright (C) 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel semantic-db ;
|
||||
USING: accessors kernel new-slots semantic-db semantic-db.context sequences ;
|
||||
IN: semantic-db.hierarchy
|
||||
|
||||
TUPLE: tree id children ;
|
||||
C: <tree> tree
|
||||
|
||||
: hierarchy-context ( -- context-id )
|
||||
"hierarchy" ensure-context ;
|
||||
|
||||
: has-parent-relation ( -- relation-id )
|
||||
! find an arc with:
|
||||
! type = relation (in semantic-db context)
|
||||
! context = hierarchy
|
||||
! name = "has parent"
|
||||
;
|
||||
|
||||
: find-children ( node-id -- children )
|
||||
! find arcs with:
|
||||
! relation = has-parent-relation
|
||||
! object = node-id
|
||||
! then load the subjects either as nodes or subtrees
|
||||
;
|
||||
|
||||
: get-node-hierarchy ( node-id -- tree )
|
||||
dup find-children <tree> ;
|
||||
|
|
|
|||
|
|
@ -3,9 +3,9 @@ IN: temporary
|
|||
|
||||
[
|
||||
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
|
||||
|
|
|
|||
|
|
@ -18,12 +18,9 @@ node "node"
|
|||
: create-node-table ( -- )
|
||||
node create-table ;
|
||||
|
||||
: create-node* ( content -- id )
|
||||
: create-node ( content -- id )
|
||||
<node> dup persist id>> ;
|
||||
|
||||
: create-node ( content -- )
|
||||
create-node* drop ;
|
||||
|
||||
TUPLE: arc relation subject object ;
|
||||
|
||||
: <arc> ( relation subject object -- arc )
|
||||
|
|
@ -41,7 +38,6 @@ arc "arc"
|
|||
|
||||
: create-arc-table ( -- )
|
||||
arc create-table ;
|
||||
! arc db-columns maybe-remove-id arc db-table create-sql sql-command ;
|
||||
|
||||
: insert-arc ( arc -- )
|
||||
dup delegate insert-tuple
|
||||
|
|
@ -53,15 +49,12 @@ arc "arc"
|
|||
: delete-arc ( arc -- )
|
||||
dup delete-tuple delegate delete-tuple ;
|
||||
|
||||
: create-arc* ( relation subject object -- id )
|
||||
: create-arc ( relation subject object -- id )
|
||||
<arc> dup persist-arc id>> ;
|
||||
|
||||
: create-arc ( relation subject object -- )
|
||||
create-arc* drop ;
|
||||
|
||||
: create-bootstrap-nodes ( -- )
|
||||
{ "context" "relation" "is of type" "semantic-db" "is in context" }
|
||||
[ create-node ] each ;
|
||||
[ create-node drop ] each ;
|
||||
|
||||
: context-type 1 ; inline
|
||||
: relation-type 2 ; inline
|
||||
|
|
@ -70,11 +63,11 @@ arc "arc"
|
|||
: has-context-relation 5 ; inline
|
||||
|
||||
: create-bootstrap-arcs ( -- )
|
||||
has-type-relation has-type-relation relation-type create-arc
|
||||
has-type-relation semantic-db-context context-type create-arc
|
||||
has-context-relation has-type-relation semantic-db-context create-arc
|
||||
has-type-relation has-context-relation relation-type create-arc
|
||||
has-context-relation has-context-relation semantic-db-context create-arc ;
|
||||
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 ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,19 @@
|
|||
! Copyright (C) 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel semantic-db ;
|
||||
IN: semantic-db.type
|
||||
|
||||
: assign-type ( type nid -- arc-id )
|
||||
has-type-relation spin create-arc ;
|
||||
|
||||
: create-node-of-type ( type name -- node-id )
|
||||
create-node [ assign-type drop ] keep ;
|
||||
|
||||
: select-node-of-type ( type name -- node-id? )
|
||||
! find a node with the given name, that is the subject of an arc with:
|
||||
! relation = has-type-relation
|
||||
! object = type
|
||||
;
|
||||
|
||||
: ensure-node-of-type ( type name -- node-id )
|
||||
2dup select-node-of-type [ 2nip ] [ create-node-of-type ] if* ;
|
||||
Loading…
Reference in New Issue