semantic-db: I like the new stuff better than the old stuff

extra/semantic-db/context/context.factor

@@ -1,19 +1,16 @@
 ! Copyright (C) 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel semantic-db semantic-db.type ;
+USING: kernel namespaces semantic-db ;
 IN: semantic-db.context
 
-! contexts:
+: create-context* ( context-name -- context-id ) create-node* ;
-!  - have type 'context' in context 'semantic-db'
+: create-context ( context-name -- ) create-context* drop ;
 
-: current-context ( -- context-id )
+: context ( -- context-id )
-    \ current-context get ;
+    \ context get ;
 
-: set-current-context ( context-id -- )
+: set-context ( context-id -- )
-    \ current-context set ;
+    \ context set ;
 
-: context-id ( name -- context-id )
+: with-context ( context-id quot -- )
-    context-type swap ensure-node-of-type ;
+    >r \ context r> with-variable ;
-
-: with-context ( name quot -- )
-    swap context-id [ set-current-context ] curry swap compose with-scope ;

extra/semantic-db/hierarchy/hierarchy.factor

@@ -1,38 +1,44 @@
 ! Copyright (C) 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel new-slots semantic-db semantic-db.relations sequences ;
+USING: accessors db.tuples kernel new-slots semantic-db semantic-db.relations sequences sequences.deep ;
 IN: semantic-db.hierarchy
 
 TUPLE: tree id children ;
 C: <tree> tree
 
-! TODO: don't use context here. Hierarchies should be created within
-! arbitrary contexts.
-: hierarchy-context ( -- context-id )
-    "hierarchy" context-id ;
-
 : has-parent-relation ( -- relation-id )
-    hierarchy-context "has parent" relation-id ;
+    "has parent" relation-id ;
 
-: parent-of ( parent child -- arc-id )
+: parent-child* ( parent child -- arc-id )
-    has-parent-relation spin create-arc ;
+    has-parent-relation spin create-arc* ;
 
-: select-parents ( child -- parents )
+: parent-child ( parent child -- )
+    parent-child* drop ;
 
+: un-parent-child ( parent child -- )
+    has-parent-relation -rot <arc> select-tuples [ id>> delete-arc ] each ;
 
-: ensure-parent ( child parent -- )
+: child-arcs ( node-id -- child-arcs )
-    ! TODO
+    has-parent-relation f rot <arc> select-tuples ;
-    ;
 
-: find-children ( node-id -- children )
+: children ( node-id -- children )
-    ! find arcs with:
+    child-arcs [ subject>> ] map ;
-    !   relation = has-parent-relation
+
-    !   object = node-id
+: parent-arcs ( node-id -- parent-arcs )
-    ! then load the subjects either as nodes or subtrees
+    has-parent-relation swap f <arc> select-tuples ;
-    ":node_id" INTEGER param
+
-    has-parent-relation ":has_parent" INTEGER param 2array
+: parents ( node-id -- parents )
-    "select a.subject from arc a where relation = :has_parent and object = :node_id"
+     parent-arcs [ object>> ] map ;
-    single-int-results ;
 
 : get-node-hierarchy ( node-id -- tree )
-    dup find-children <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 ;

extra/semantic-db/relations/relations.factor

@@ -1,27 +1,26 @@
 ! Copyright (C) 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel semantic-db semantic-db.context semantic-db.type ;
+USING: db.types kernel namespaces semantic-db semantic-db.context
+sequences.lib ;
 IN: semantic-db.relations
 
 ! relations:
-!  - have type 'relation' in context 'semantic-db'
 !  - have a context in context 'semantic-db'
 
-: create-relation ( context-id relation-name -- relation-id )
+: create-relation* ( context-id relation-name -- relation-id )
-    relation-type swap ensure-node-of-type
+    create-node* tuck has-context-relation spin create-arc ;
-    tuck has-context-relation spin create-arc ;
 
-: select-relation ( context-id relation-name -- relation-id/f )
+: create-relation ( context-id relation-name -- )
+    create-relation* drop ;
+
+: get-relation ( context-id relation-name -- relation-id/f )
     [
         ":name" TEXT param ,
-        has-type-relation ":has_type" INTEGER param ,
-        relation-type ":relation_type" INTEGER param ,
         ":context" INTEGER param ,
         has-context-relation ":has_context" INTEGER param ,
     ] { } make
-    "select n.id from node n, arc a, arc b where n.content = :name and n.id = a.subject and a.relation = :has_type and a.object = :relation_type and n.id = b.subject and b.relation = :has_context and b.object = :context"
+    "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 ;
+    single-int-results ?first ;
 
-: relation-id ( context-id relation-name -- relation-id )
+: relation-id ( relation-name -- relation-id )
-    [ select-relation ] [ create-relation ] ensure2 ;
+    context swap [ get-relation ] [ create-relation* ] ensure2 ;
-    ! 2dup select-relation [ 2nip ] [ create-relation ] if* ;

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

@@ -1,26 +1,58 @@
-USING: accessors arrays db db.sqlite db.tuples kernel math semantic-db semantic-db.type sequences tools.test tools.walker ;
+USING: accessors arrays db db.sqlite db.tuples kernel math namespaces
-IN: temporary
+semantic-db semantic-db.context semantic-db.hierarchy semantic-db.relations
+sequences tools.test tools.walker ;
+IN: vocab.tests
 
 [
     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-tmp-sqlite
 
 [
     init-semantic-db
-    type-type 1array [ "type" ensure-type ] unit-test
+    "test content" create-context* [
-    [ { 1 2 3 } ] [ type-type select-nodes-of-type ] unit-test
+        [ 4 ] [ context ] unit-test
-    [ 1 ] [ type-type select-node-of-type ] unit-test
+        [ 5 ] [ context "is test content" create-relation* ] unit-test
-    [ t ] [ "content" ensure-type integer? ] unit-test
+        [ 5 ] [ context "is test content" get-relation ] unit-test
-    [ t ] [ "content" ensure-type "content" ensure-type = ] unit-test
+        [ 5 ] [ "is test content" relation-id ] unit-test
-    [ t ] [ "content" ensure-type "first content" create-node-of-type integer? ] unit-test
+        [ 7 ] [ "has parent" relation-id ] unit-test
-    [ t ] [ "content" ensure-type select-node-of-type integer? ] unit-test
+        [ 7 ] [ "has parent" relation-id ] unit-test
-    [ t ] [ "content" ensure-type "first content" select-node-of-type-with-content integer? ] unit-test
+        [ "has parent" ] [ "has parent" relation-id node-content ] unit-test
-    [ t ] [ "content" ensure-type "first content" ensure-node-of-type integer? ] unit-test
+        [ "test content" ] [ context node-content ] unit-test
-    [ t ] [ "content" ensure-type "second content" ensure-node-of-type integer? ] unit-test
+    ] with-context
-    [ 2 ] [ "content" ensure-type select-nodes-of-type length ] 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-tmp-sqlite
+
+! test hierarchy
+[
+    init-semantic-db
+    "family tree" create-context* [
+        "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 parent-child* integer? ] unit-test
+        { { "eve" "bob" } { "eve" "fran" } { "bob" "gertrude" } { "fran" "charlie" } } [ first2 [ get ] 2apply parent-child ] each
+        [ { "bob" "fran" } ] [ "eve" get children [ node-content ] map ] unit-test
+        [ { "adam" "eve" } ] [ "bob" 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
+        [ { "adam" "eve" } ] [ "charlie" get get-root-nodes ] unit-test
+        [ { } ] [ "fran" get "charlie" get tuck un-parent-child parents ] unit-test
+    ] with-context
 ] with-tmp-sqlite

extra/semantic-db/semantic-db.factor

@@ -7,6 +7,9 @@ TUPLE: node id content ;
 : <node> ( content -- node )
     node construct-empty swap >>content ;
 
+: <id-node> ( id -- node )
+    node construct-empty swap >>id ;
+
 node "node"
 {
     { "id" "id" +native-id+ +autoincrement+ }
@@ -16,14 +19,38 @@ node "node"
 : create-node-table ( -- )
     node create-table ;
 
-: create-node ( content -- id )
+: delete-node ( node-id -- )
+    <id-node> delete-tuple ;
+
+: 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 ;
 
 : <arc> ( relation subject object -- arc )
     arc construct-empty swap >>object swap >>subject swap >>relation ;
 
+: <id-arc> ( id -- arc )
+    arc construct-empty swap >>id ;
+
+: insert-arc ( arc -- )
+    f <node> dup insert-tuple id>> >>id insert-tuple ;
+
+: delete-arc ( arc-id -- )
+    dup delete-node <id-arc> delete-tuple ;
+
+: create-arc* ( relation subject object -- 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?
@@ -35,47 +62,15 @@ arc "arc"
 : create-arc-table ( -- )
     arc create-table ;
 
-: insert-arc ( arc -- )
-    f <node> dup insert-tuple id>> >>id insert-tuple ;
-
-: delete-arc ( arc -- )
-    dup delete-tuple delegate delete-tuple ;
-
-: create-arc ( relation subject object -- id )
-    <arc> dup insert-arc id>> ;
-
 : create-bootstrap-nodes ( -- )
-    { "context" "type" "relation" "has type" "semantic-db" "has context" }
+    "semantic-db" create-node
-    [ create-node drop ] each ;
+    "has context" create-node ;
 
-! TODO: maybe put these in a 'special nodes' table
+: semantic-db-context 1 ;
-: context-type 1 ; inline
+: has-context-relation 2 ;
-: type-type 2 ; inline
-: relation-type 3 ; inline
-: has-type-relation 4 ; inline
-: semantic-db-context 5 ; inline
-: has-context-relation 6 ; inline
-
-: has-semantic-db-context ( id -- )
-    has-context-relation swap semantic-db-context create-arc drop ;
-
-: has-type-in-semantic-db ( subject type -- )
-    has-type-relation -rot create-arc drop ;
 
 : create-bootstrap-arcs ( -- )
-    ! give everything a type
+    has-context-relation has-context-relation semantic-db-context create-arc ;    
-    context-type type-type has-type-in-semantic-db
-    type-type type-type has-type-in-semantic-db
-    relation-type type-type has-type-in-semantic-db
-    has-type-relation relation-type has-type-in-semantic-db
-    semantic-db-context context-type has-type-in-semantic-db
-    has-context-relation relation-type has-type-in-semantic-db
-    ! give relations and types the semantic-db context
-    context-type has-semantic-db-context
-    type-type has-semantic-db-context
-    relation-type has-semantic-db-context
-    has-type-relation has-semantic-db-context
-    has-context-relation has-semantic-db-context ;
 
 : init-semantic-db ( -- )
     create-node-table create-arc-table create-bootstrap-nodes create-bootstrap-arcs ;

extra/semantic-db/type/type.factor

@@ -8,10 +8,10 @@ IN: semantic-db.type
 !  - have a context in context 'semantic-db'
 
 : assign-type ( type nid -- arc-id )
-    has-type-relation spin create-arc ;
+    has-type-relation spin arc-id ;
 
 : create-node-of-type ( type content -- node-id )
-    create-node [ assign-type drop ] keep ;
+    node-id [ assign-type drop ] keep ;
 
 : select-nodes-of-type ( type -- node-ids )
     ":type" INTEGER param
@@ -33,7 +33,7 @@ IN: semantic-db.type
     single-int-results ;
 
 : select-node-of-type-with-content ( type content -- node-id/f )
-    select-nodes-of-type-with-content 1result ;
+    select-nodes-of-type-with-content ?first ;
 
 : ensure-node-of-type ( type content -- node-id )
     [ select-node-of-type-with-content ] [ create-node-of-type ] ensure2 ;