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

semantic-db: add RELATION:

db4
Alex Chapman 2008-03-21 02:01:58 +11:00
parent 49bc76eace
commit 3df71e5447
2 changed files with 81 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -14,15 +14,13 @@ SYMBOL: has-parent-relation
delete-db
test-db [
create-node-table create-arc-table
node create-table arc create-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
] with-db
delete-db
] with-db delete-db
test-db [
init-semantic-db
@ -35,20 +33,7 @@ test-db [
[ 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
! [ 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-db
delete-db
] with-db delete-db
! test hierarchy
test-db [
@ -68,6 +53,12 @@ test-db [
[ "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
] with-db delete-db
RELATION: test-relation
test-db [
init-semantic-db
[ 5 ] [ test-relation ] unit-test
] with-db delete-db
delete-db

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

@ -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 hashtables kernel math math.parser namespaces new-slots sequences sequences.deep sequences.lib ;
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 ;
IN: semantic-db
TUPLE: node id content ;
@ -16,9 +16,6 @@ node "node"
{ "content" "content" TEXT }
} define-persistent
: create-node-table ( -- )
node create-table ;
: delete-node ( node-id -- )
<id-node> delete-tuple ;
@ -45,6 +42,30 @@ TUPLE: arc id subject object relation ;
: create-arc ( subject object relation -- arc-id )
<arc> dup insert-arc id>> ;
: has-arc? ( subject object relation -- ? )
<arc> select-tuples length 0 > ;
: select-arcs ( subject object relation -- arcs )
<arc> select-tuples ;
: select-arc-ids ( subject object relation -- arc-ids )
select-arcs [ id>> ] map ;
: select-arc-subjects ( subject object relation -- subject-ids )
select-arcs [ subject>> ] map ;
: select-arc-objects ( subject object relation -- object-ids )
select-arcs [ object>> ] map ;
: 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?
@ -53,20 +74,20 @@ arc "arc"
{ "object" "object" INTEGER +not-null+ }
} define-persistent
: create-arc-table ( -- ) arc create-table ;
: create-bootstrap-nodes ( -- )
"semantic-db" create-node drop
"has context" create-node drop ;
"has-context" create-node drop ;
: semantic-db-context 1 ;
: semantic-db-context 1 ;
: has-context-relation 2 ;
: create-bootstrap-arcs ( -- )
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 ;
node create-table
arc create-table
create-bootstrap-nodes create-bootstrap-arcs ;
: param ( value key type -- param )
swapd 3array ;
@ -75,13 +96,31 @@ arc "arc"
f f <simple-statement> [ do-bound-query ] with-disposal
[ first string>number ] map ;
: ensure1 ( x quot1 quot2 -- y )
#! quot1 ( x -- y/f ) tries to find an existing y
#! quot2 ( x -- y ) creates a new y if quot1 returns f
>r dupd call [ nip ] r> if* ;
: ensure2 ( x y quot1 quot2 -- z )
#! quot1 ( x y -- z/f ) finds an existing z
#! quot1 ( x y -- z/f ) tries to find an existing z
#! quot2 ( x y -- z ) creates a new z if quot1 returns f
>r >r 2dup r> call [ 2nip ] r> if* ;
! contexts:
! - a node n is a context iff there exists a relation r such that r has context n
: create-context ( context-name -- context-id ) create-node ;
: get-context ( context-name -- context-id/f )
[
":name" TEXT param ,
has-context-relation ":has_context" INTEGER param ,
] { } make
"select distinct n.id from node n, arc a where n.content = :name and a.relation = :has_context and a.object = n.id"
single-int-results ?first ;
: context-id ( context-name -- context-id )
[ get-context ] [ create-context ] ensure1 ;
! relations:
! - have a context in context 'semantic-db'
@ -100,26 +139,28 @@ 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
: RELATION:
CREATE-WORD dup [ word-name ] [ word-vocabulary ] bi
[ context-id relation-id ] 2curry define ; parsing
! hierarchy
TUPLE: tree id children ;
C: <tree> tree
: parent-child ( parent child has-parent-relation -- arc-id ) swapd create-arc ;
: 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 ;
swapd delete-arcs ;
: 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 ;
object-relation select-arc-subjects ;
: parents ( node-id has-parent-relation -- parents )
parent-arcs [ object>> ] map ;
subject-relation select-arc-objects ;
: get-node-hierarchy ( node-id has-parent-relation -- tree )
2dup children >r [ get-node-hierarchy ] curry r> swap map <tree> ;
@ -135,11 +176,13 @@ C: <tree> tree
(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 > ;
: 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 )
f -rot <arc> select-tuples [ id>> ] map ;
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 ;