semantic-db: new RELATION: syntax
Alex Chapman
parent
3df71e5447
commit
43aba96e8c
|
|
@ -5,7 +5,6 @@ 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 ;
|
||||
|
|
@ -22,43 +21,43 @@ test-db [
|
|||
[ 5 ] [ 1 2 3 create-arc ] unit-test
|
||||
] with-db delete-db
|
||||
|
||||
test-db [
|
||||
init-semantic-db
|
||||
"test content" create-context context set
|
||||
[ 4 ] [ context get ] 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
|
||||
] with-db delete-db
|
||||
test-db [
|
||||
init-semantic-db
|
||||
"test content" create-context context set
|
||||
[ 4 ] [ context get ] 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
|
||||
] with-db delete-db
|
||||
|
||||
! test hierarchy
|
||||
test-db [
|
||||
init-semantic-db
|
||||
"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
|
||||
! "test1" f f f f f <relation-definition> define-relation
|
||||
! "test2" t t t t t <relation-definition> define-relation
|
||||
RELATION: test
|
||||
test-db [
|
||||
init-semantic-db
|
||||
[ 5 ] [ test-relation ] unit-test
|
||||
] with-db delete-db
|
||||
|
||||
RELATION: test-relation
|
||||
|
||||
test-db [
|
||||
init-semantic-db
|
||||
[ 5 ] [ test-relation ] unit-test
|
||||
] with-db delete-db
|
||||
! test hierarchy
|
||||
RELATION: has-parent
|
||||
test-db [
|
||||
init-semantic-db
|
||||
"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 ] [ "bob" get "adam" get has-parent integer? ] unit-test
|
||||
{ { "bob" "eve" } { "fran" "eve" } { "gertrude" "bob" } { "fran" "bob" } { "charlie" "fran" } } [ first2 [ get ] 2apply has-parent drop ] each
|
||||
[ { "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
|
||||
[ "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
|
||||
[ { "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
|
||||
] 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 combinators.cleave continuations db db.tuples db.types db.sqlite hashtables kernel math math.parser namespaces new-slots parser sequences sequences.deep sequences.lib words ;
|
||||
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 ;
|
||||
IN: semantic-db
|
||||
|
||||
TUPLE: node id content ;
|
||||
|
|
@ -54,18 +54,18 @@ TUPLE: arc id subject object relation ;
|
|||
: select-arc-subjects ( subject object relation -- subject-ids )
|
||||
select-arcs [ subject>> ] map ;
|
||||
|
||||
: select-subjects ( object relation -- subject-ids )
|
||||
f -rot select-arc-subjects ;
|
||||
|
||||
: select-arc-objects ( subject object relation -- object-ids )
|
||||
select-arcs [ object>> ] map ;
|
||||
|
||||
: select-objects ( subject relation -- object-ids )
|
||||
f swap select-arc-objects ;
|
||||
|
||||
: delete-arcs ( subject object relation -- )
|
||||
select-arcs [ id>> delete-arc ] each ;
|
||||
|
||||
: subject-relation ( subject relation -- subject object relation )
|
||||
f swap ;
|
||||
|
||||
: object-relation ( object relation -- subject object relation )
|
||||
f -rot ;
|
||||
|
||||
arc "arc"
|
||||
{
|
||||
{ "id" "id" INTEGER +assigned-id+ } ! foreign key to node table?
|
||||
|
|
@ -139,28 +139,67 @@ arc "arc"
|
|||
: relation-id ( relation-name context-id -- relation-id )
|
||||
[ get-relation ] [ create-relation ] ensure2 ;
|
||||
|
||||
! RELATION: is-fooey
|
||||
! - define a word is-fooey in the current vocab (foo), that when called:
|
||||
! - finds or creates a node called "is-fooey" with context "foo", and returns its id
|
||||
TUPLE: relation-definition relate id-word unrelate related? subjects objects ;
|
||||
C: <relation-definition> relation-definition
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: default-word-name ( relate-word-name word-type -- word-name )
|
||||
{
|
||||
{ "relate" [ ] }
|
||||
{ "id-word" [ "-relation" append ] }
|
||||
{ "unrelate" [ "!" swap append ] }
|
||||
{ "related?" [ "?" append ] }
|
||||
{ "subjects" [ "-subjects" append ] }
|
||||
{ "objects" [ "-objects" append ] }
|
||||
} case ;
|
||||
|
||||
: choose-word-name ( relation-definition given-word-name word-type -- word-name )
|
||||
over string? [
|
||||
drop nip
|
||||
] [
|
||||
nip [ relate>> ] dip default-word-name
|
||||
] if ;
|
||||
|
||||
: (define-relation-word) ( id-word word-name definition -- id-word )
|
||||
>r create-in over [ execute ] curry r> compose define ;
|
||||
|
||||
: define-relation-word ( relation-definition id-word given-word-name word-type definition -- relation-definition id-word )
|
||||
>r >r [
|
||||
pick swap r> choose-word-name r> (define-relation-word)
|
||||
] [
|
||||
r> r> 2drop
|
||||
] if* ;
|
||||
|
||||
: define-relation-words ( relation-definition id-word -- )
|
||||
over relate>> "relate" [ create-arc ] define-relation-word
|
||||
over unrelate>> "unrelate" [ delete-arcs ] define-relation-word
|
||||
over related?>> "related?" [ has-arc? ] define-relation-word
|
||||
over subjects>> "subjects" [ select-subjects ] define-relation-word
|
||||
over objects>> "objects" [ select-objects ] define-relation-word
|
||||
2drop ;
|
||||
|
||||
: define-id-word ( relation-definition id-word -- )
|
||||
[ relate>> ] dip tuck word-vocabulary
|
||||
[ context-id relation-id ] 2curry define ;
|
||||
|
||||
: create-id-word ( relation-definition -- id-word )
|
||||
dup id-word>> "id-word" choose-word-name create-in ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: define-relation ( relation-definition -- )
|
||||
dup create-id-word 2dup define-id-word define-relation-words ;
|
||||
|
||||
: RELATION:
|
||||
CREATE-WORD dup [ word-name ] [ word-vocabulary ] bi
|
||||
[ context-id relation-id ] 2curry define ; parsing
|
||||
scan t t t t t <relation-definition> define-relation ; parsing
|
||||
|
||||
! 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 delete-arcs ;
|
||||
|
||||
: children ( node-id has-parent-relation -- children )
|
||||
object-relation select-arc-subjects ;
|
||||
|
||||
: parents ( node-id has-parent-relation -- parents )
|
||||
subject-relation select-arc-objects ;
|
||||
: children ( node-id has-parent-relation -- children ) select-subjects ;
|
||||
: parents ( node-id has-parent-relation -- parents ) select-objects ;
|
||||
|
||||
: get-node-hierarchy ( node-id has-parent-relation -- tree )
|
||||
2dup children >r [ get-node-hierarchy ] curry r> swap map <tree> ;
|
||||
|
|
@ -175,14 +214,3 @@ C: <tree> tree
|
|||
: get-root-nodes ( node-id has-parent-relation -- root-nodes )
|
||||
(get-root-nodes) flatten prune ;
|
||||
|
||||
! sets
|
||||
: in-set ( member set in-set-relation -- arc-id ) create-arc ;
|
||||
: in-set? ( member set in-set-relation -- ? ) has-arc? ;
|
||||
: set-members ( set in-set-relation -- members )
|
||||
object-relation select-arc-subjects ;
|
||||
|
||||
! attributes
|
||||
: has-attribute ( node value has-attribute-relation -- arc-id ) create-arc ;
|
||||
: has-attribute? ( node value has-attribute-relation -- ? ) has-arc? ;
|
||||
: nodes-with-attribute ( value has-attribute-relation -- node-ids )
|
||||
object-relation select-arc-subjects ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue