semantic-db: move everything into one vocab

extra/semantic-db/context/context.factor

@@ -1,10 +0,0 @@
-! Copyright (C) 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces semantic-db ;
-IN: semantic-db.context
-
-: create-context* ( context-name -- context-id ) create-node* ;
-: create-context ( context-name -- ) create-context* drop ;
-
-SYMBOL: context
-

extra/semantic-db/hierarchy/hierarchy.factor

@@ -1,44 +0,0 @@
-! Copyright (C) 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors db.tuples hashtables kernel namespaces new-slots
-semantic-db semantic-db.relations sequences sequences.deep ;
-IN: semantic-db.hierarchy
-
-TUPLE: tree id children ;
-C: <tree> tree
-
-SYMBOL: has-parent-relation
-
-: parent-child* ( parent child -- arc-id )
-    has-parent-relation get spin create-arc* ;
-
-: parent-child ( parent child -- )
-    parent-child* drop ;
-
-: un-parent-child ( parent child -- )
-    has-parent-relation get spin <arc> select-tuples [ id>> delete-arc ] each ;
-
-: child-arcs ( node-id -- child-arcs )
-    has-parent-relation get f rot <arc> select-tuples ;
-
-: children ( node-id -- children )
-    child-arcs [ subject>> ] map ;
-
-: parent-arcs ( node-id -- parent-arcs )
-    has-parent-relation get swap f <arc> select-tuples ;
-
-: parents ( node-id -- parents )
-     parent-arcs [ object>> ] map ;
-
-: get-node-hierarchy ( node-id -- 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 prune ;

extra/semantic-db/membership/membership.factor

@@ -1,6 +0,0 @@
-! Copyright (C) 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel new-slots semantic-db semantic-db.relations ;
-IN: semantic-db.membership
-
-

extra/semantic-db/relations/relations.factor

@@ -1,26 +0,0 @@
-! Copyright (C) 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: db.types kernel namespaces semantic-db semantic-db.context
-sequences.lib ;
-IN: semantic-db.relations
-
-! relations:
-!  - have a context in context 'semantic-db'
-
-: create-relation* ( context-id relation-name -- relation-id )
-    create-node* tuck has-context-relation spin create-arc ;
-
-: create-relation ( context-id relation-name -- )
-    create-relation* drop ;
-
-: get-relation ( context-id relation-name -- relation-id/f )
-    [
-        ":name" TEXT param ,
-        ":context" INTEGER param ,
-        has-context-relation ":has_context" INTEGER param ,
-    ] { } make
-    "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 ( relation-name -- relation-id )
-    context get swap [ get-relation ] [ create-relation* ] ensure2 ;

extra/semantic-db/semantic-db-tests.factor

@@ -1,10 +1,12 @@
-USING: accessors arrays continuations db db.sqlite
+USING: accessors arrays continuations db db.sqlite db.tuples io.files
-db.tuples io.files kernel math namespaces semantic-db
+kernel math namespaces semantic-db
-semantic-db.context semantic-db.hierarchy
+
-semantic-db.relations sequences sorting tools.test
+sequences sorting tools.test tools.walker ;
-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 ;
 : delete-db [ db-path delete-file ] ignore-errors ;
@@ -13,25 +15,25 @@ delete-db
 
 test-db [
     create-node-table create-arc-table
-    [ 1 ] [ "first node" create-node* ] unit-test
+    [ 1 ] [ "first node" create-node ] unit-test
-    [ 2 ] [ "second node" create-node* ] unit-test
+    [ 2 ] [ "second node" create-node ] unit-test
-    [ 3 ] [ "third node" create-node* ] unit-test
+    [ 3 ] [ "third node" create-node ] unit-test
-    [ 4 ] [ f create-node* ] unit-test
+    [ 4 ] [ f create-node ] unit-test
-    [ 5 ] [ 1 2 3 create-arc* ] unit-test
+    [ 5 ] [ 1 2 3 create-arc ] unit-test
 ] with-db
 
 delete-db
 
 test-db [
     init-semantic-db
-    "test content" create-context* context set
+    "test content" create-context context set
     [ 4 ] [ context get ] unit-test
-    [ 5 ] [ context get "is test content" create-relation* ] unit-test
+    [ 5 ] [ "is test content" context get create-relation ] unit-test
-    [ 5 ] [ context get "is test content" get-relation ] unit-test
+    [ 5 ] [ "is test content" context get get-relation ] unit-test
-    [ 5 ] [ "is test content" relation-id ] unit-test
+    [ 5 ] [ "is test content" context get relation-id ] unit-test
-    [ 7 ] [ "has parent" relation-id ] unit-test
+    [ 7 ] [ "has parent" context get relation-id ] unit-test
-    [ 7 ] [ "has parent" relation-id ] unit-test
+    [ 7 ] [ "has parent" context get relation-id ] unit-test
-    [ "has parent" ] [ "has parent" 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
     ! type-type 1array [ "type" ensure-type ] unit-test
     ! [ { 1 2 3 } ] [ type-type select-nodes-of-type ] unit-test
@@ -51,21 +53,21 @@ delete-db
 ! test hierarchy
 test-db [
     init-semantic-db
-    "family tree" create-context* context set
+    "family tree" create-context context set
-    "has parent" relation-id has-parent-relation set
+    "has parent" context get relation-id has-parent-relation set
-    "adam" create-node* "adam" set
+    "adam" create-node "adam" set
-    "eve" create-node* "eve" set
+    "eve" create-node "eve" set
-    "bob" create-node* "bob" set
+    "bob" create-node "bob" set
-    "fran" create-node* "fran" set
+    "fran" create-node "fran" set
-    "charlie" create-node* "charlie" set
+    "charlie" create-node "charlie" set
-    "gertrude" create-node* "gertrude" set
+    "gertrude" create-node "gertrude" set
-    [ t ] [ "adam" get "bob" get parent-child* integer? ] unit-test
+     [ 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 parent-child ] each
+    { { "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 children [ node-content ] map ] unit-test
+    [ { "bob" "fran" } ] [ "eve" get has-parent-relation get children [ node-content ] map ] unit-test
-    [ { "adam" "eve" } ] [ "bob" get parents [ node-content ] map ] unit-test
+    [ { "adam" "eve" } ] [ "bob" get has-parent-relation 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
+    [ "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 get-root-nodes [ node-content ] map natural-sort >array ] 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 un-parent-child parents [ node-content ] map ] 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

extra/semantic-db/semantic-db.factor

@@ -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 kernel math math.parser new-slots sequences ;
+USING: accessors arrays continuations db db.tuples db.types db.sqlite hashtables kernel math math.parser namespaces new-slots sequences sequences.deep sequences.lib ;
 IN: semantic-db
 
 TUPLE: node id content ;
@@ -22,19 +22,16 @@ node "node"
 : delete-node ( node-id -- )
     <id-node> delete-tuple ;
 
-: create-node* ( str -- node-id )
+: 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 ;
+TUPLE: arc id subject object relation ;
 
-: <arc> ( relation subject object -- arc )
+: <arc> ( subject object relation -- arc )
-    arc construct-empty swap >>object swap >>subject swap >>relation ;
+    arc construct-empty swap >>relation swap >>object swap >>subject ;
 
 : <id-arc> ( id -- arc )
     arc construct-empty swap >>id ;
@@ -45,12 +42,9 @@ TUPLE: arc id relation subject object ;
 : delete-arc ( arc-id -- )
     dup delete-node <id-arc> delete-tuple ;
 
-: create-arc* ( relation subject object -- arc-id )
+: create-arc ( subject object relation -- 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?
@@ -59,18 +53,17 @@ arc "arc"
     { "object" "object" INTEGER +not-null+ }
 } define-persistent
 
-: create-arc-table ( -- )
+: create-arc-table ( -- ) arc create-table ;
-    arc create-table ;
 
 : create-bootstrap-nodes ( -- )
-    "semantic-db" create-node
+    "semantic-db" create-node drop
-    "has context" create-node ;
+    "has context" create-node drop ;
 
 : semantic-db-context 1 ;
 : has-context-relation 2 ;
 
 : create-bootstrap-arcs ( -- )
-    has-context-relation has-context-relation semantic-db-context create-arc ;    
+    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 ;
@@ -87,3 +80,66 @@ arc "arc"
     #! quot2 ( x y -- z ) creates a new z if quot1 returns f
     >r >r 2dup r> call [ 2nip ] r> if* ;
 
+: create-context ( context-name -- context-id ) create-node ;
+
+! relations:
+!  - have a context in context 'semantic-db'
+
+: create-relation ( relation-name context-id -- relation-id )
+    [ create-node dup ] dip has-context-relation create-arc drop ;
+
+: get-relation ( relation-name context-id -- relation-id/f )
+    [
+        ":context" INTEGER param ,
+        ":name" TEXT param ,
+        has-context-relation ":has_context" INTEGER param ,
+    ] { } make
+    "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 ( relation-name context-id -- relation-id )
+    [ get-relation ] [ create-relation ] ensure2 ;
+
+! 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 <arc> select-tuples [ id>> delete-arc ] each ;
+
+: child-arcs ( parent-id has-parent-relation -- child-arcs )
+    f -rot <arc> select-tuples ;
+
+: 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 ;
+
+: parents ( node-id has-parent-relation -- parents )
+     parent-arcs [ object>> ] map ;
+
+: get-node-hierarchy ( node-id has-parent-relation -- tree )
+    2dup children >r [ get-node-hierarchy ] curry r> swap map <tree> ;
+
+: (get-root-nodes) ( node-id has-parent-relation -- root-nodes/node-id )
+    2dup parents dup empty? [
+        2drop
+    ] [
+        >r nip [ (get-root-nodes) ] curry r> swap map
+    ] if ;
+
+: get-root-nodes ( node-id has-parent-relation -- root-nodes )
+    (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 > ;
+
+: set-members ( set in-set-relation -- members )
+    f -rot <arc> select-tuples [ id>> ] map ;