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

semantic-db: new RELATION: syntax

db4
Alex Chapman 2008-03-25 17:38:14 +11:00
parent 3df71e5447
commit 43aba96e8c
2 changed files with 102 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -5,7 +5,6 @@ sequences sorting tools.test tools.walker ;
IN: semantic-db.tests IN: semantic-db.tests
SYMBOL: context SYMBOL: context
SYMBOL: has-parent-relation
: db-path "semantic-db-test.db" temp-file ; : db-path "semantic-db-test.db" temp-file ;
: test-db db-path sqlite-db ; : test-db db-path sqlite-db ;
@ -22,43 +21,43 @@ test-db [
[ 5 ] [ 1 2 3 create-arc ] unit-test [ 5 ] [ 1 2 3 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 [ 4 ] [ context get ] unit-test
[ 5 ] [ "is test content" context get create-relation ] 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 get-relation ] unit-test
[ 5 ] [ "is test content" context get relation-id ] 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
[ 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 [ "has parent" ] [ "has parent" context get relation-id 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
! test hierarchy ! "test1" f f f f f <relation-definition> define-relation
test-db [ ! "test2" t t t t t <relation-definition> define-relation
init-semantic-db RELATION: test
"family tree" create-context context set test-db [
"has parent" context get relation-id has-parent-relation set init-semantic-db
"adam" create-node "adam" set [ 5 ] [ test-relation ] unit-test
"eve" create-node "eve" set ] with-db delete-db
"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
RELATION: test-relation ! test hierarchy
RELATION: has-parent
test-db [ test-db [
init-semantic-db init-semantic-db
[ 5 ] [ test-relation ] unit-test "adam" create-node "adam" set
] with-db delete-db "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

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

@ -1,6 +1,6 @@
! 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.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 IN: semantic-db
TUPLE: node id content ; TUPLE: node id content ;
@ -54,18 +54,18 @@ TUPLE: arc id subject object relation ;
: select-arc-subjects ( subject object relation -- subject-ids ) : select-arc-subjects ( subject object relation -- subject-ids )
select-arcs [ subject>> ] map ; select-arcs [ subject>> ] map ;
: select-subjects ( object relation -- subject-ids )
f -rot select-arc-subjects ;
: select-arc-objects ( subject object relation -- object-ids ) : select-arc-objects ( subject object relation -- object-ids )
select-arcs [ object>> ] map ; select-arcs [ object>> ] map ;
: select-objects ( subject relation -- object-ids )
f swap select-arc-objects ;
: delete-arcs ( subject object relation -- ) : delete-arcs ( subject object relation -- )
select-arcs [ id>> delete-arc ] each ; 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" arc "arc"
{ {
{ "id" "id" INTEGER +assigned-id+ } ! foreign key to node table? { "id" "id" INTEGER +assigned-id+ } ! foreign key to node table?
@ -139,28 +139,67 @@ arc "arc"
: relation-id ( relation-name context-id -- relation-id ) : relation-id ( relation-name context-id -- relation-id )
[ get-relation ] [ create-relation ] ensure2 ; [ get-relation ] [ create-relation ] ensure2 ;
! RELATION: is-fooey TUPLE: relation-definition relate id-word unrelate related? subjects objects ;
! - define a word is-fooey in the current vocab (foo), that when called: C: <relation-definition> relation-definition
! - finds or creates a node called "is-fooey" with context "foo", and returns its id
<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: : RELATION:
CREATE-WORD dup [ word-name ] [ word-vocabulary ] bi scan t t t t t <relation-definition> define-relation ; parsing
[ context-id relation-id ] 2curry define ; parsing
! hierarchy ! hierarchy
TUPLE: tree id children ; TUPLE: tree id children ;
C: <tree> tree C: <tree> tree
: parent-child ( parent child has-parent-relation -- arc-id ) : children ( node-id has-parent-relation -- children ) select-subjects ;
swapd create-arc ; : parents ( node-id has-parent-relation -- parents ) select-objects ;
: 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 ;
: get-node-hierarchy ( node-id has-parent-relation -- tree ) : get-node-hierarchy ( node-id has-parent-relation -- tree )
2dup children >r [ get-node-hierarchy ] curry r> swap map <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 ( node-id has-parent-relation -- root-nodes )
(get-root-nodes) flatten prune ; (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 ;