semantic-db: committing latest changes

extra/semantic-db/context/context.factor

@@ -6,11 +6,5 @@ IN: semantic-db.context
 : create-context* ( context-name -- context-id ) create-node* ;
 : create-context ( context-name -- ) create-context* drop ;
 
-: context ( -- context-id )
+SYMBOL: context
-    \ context get ;
 
-: set-context ( context-id -- )
-    \ context set ;
-
-: with-context ( context-id quot -- )
-    >r \ context r> with-variable ;

extra/semantic-db/hierarchy/hierarchy.factor

@@ -1,32 +1,31 @@
 ! Copyright (C) 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors db.tuples hashtables kernel new-slots
+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
 
-: has-parent-relation ( -- relation-id )
+SYMBOL: has-parent-relation
-    "has parent" relation-id ;
 
 : parent-child* ( parent child -- arc-id )
-    has-parent-relation spin create-arc* ;
+    has-parent-relation get spin create-arc* ;
 
 : parent-child ( parent child -- )
     parent-child* drop ;
 
 : un-parent-child ( parent child -- )
-    has-parent-relation spin <arc> select-tuples [ id>> delete-arc ] each ;
+    has-parent-relation get spin <arc> select-tuples [ id>> delete-arc ] each ;
 
 : child-arcs ( node-id -- child-arcs )
-    has-parent-relation f rot <arc> select-tuples ;
+    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 swap f <arc> select-tuples ;
+    has-parent-relation get swap f <arc> select-tuples ;
 
 : parents ( node-id -- parents )
      parent-arcs [ object>> ] map ;

extra/semantic-db/membership/membership.factor

@@ -0,0 +1,6 @@
+! 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

@@ -23,4 +23,4 @@ IN: semantic-db.relations
     single-int-results ?first ;
 
 : relation-id ( relation-name -- relation-id )
-    context swap [ get-relation ] [ create-relation* ] ensure2 ;
+    context get swap [ get-relation ] [ create-relation* ] ensure2 ;

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

@@ -24,16 +24,15 @@ delete-db
 
 test-db [
     init-semantic-db
-    "test content" create-context* [
+    "test content" create-context* context set
-        [ 4 ] [ context ] unit-test
+    [ 4 ] [ context get ] unit-test
-        [ 5 ] [ context "is test content" create-relation* ] unit-test
+    [ 5 ] [ context get "is test content" create-relation* ] unit-test
-        [ 5 ] [ context "is test content" get-relation ] unit-test
+    [ 5 ] [ context get "is test content" get-relation ] unit-test
-        [ 5 ] [ "is test content" relation-id ] unit-test
+    [ 5 ] [ "is test content" relation-id ] unit-test
-        [ 7 ] [ "has parent" relation-id ] unit-test
+    [ 7 ] [ "has parent" relation-id ] unit-test
-        [ 7 ] [ "has parent" relation-id ] unit-test
+    [ 7 ] [ "has parent" relation-id ] unit-test
-        [ "has parent" ] [ "has parent" relation-id node-content ] unit-test
+    [ "has parent" ] [ "has parent" relation-id node-content ] unit-test
-        [ "test content" ] [ context node-content ] unit-test
+    [ "test content" ] [ context get node-content ] unit-test
-    ] with-context
     ! 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
@@ -52,21 +51,21 @@ delete-db
 ! test hierarchy
 test-db [
     init-semantic-db
-    "family tree" create-context* [
+    "family tree" create-context* context set
-        "adam" create-node* "adam" set
+    "has parent" relation-id has-parent-relation set
-        "eve" create-node* "eve" set
+    "adam" create-node* "adam" set
-        "bob" create-node* "bob" set
+    "eve" create-node* "eve" set
-        "fran" create-node* "fran" set
+    "bob" create-node* "bob" set
-        "charlie" create-node* "charlie" set
+    "fran" create-node* "fran" set
-        "gertrude" create-node* "gertrude" set
+    "charlie" create-node* "charlie" set
-        [ t ] [ "adam" get "bob" get parent-child* integer? ] unit-test
+    "gertrude" create-node* "gertrude" set
-        { { "eve" "bob" } { "eve" "fran" } { "bob" "gertrude" } { "bob" "fran" } { "fran" "charlie" } } [ first2 [ get ] 2apply parent-child ] each
+    [ t ] [ "adam" get "bob" get parent-child* integer? ] unit-test
-        [ { "bob" "fran" } ] [ "eve" get children [ node-content ] map ] unit-test
+    { { "eve" "bob" } { "eve" "fran" } { "bob" "gertrude" } { "bob" "fran" } { "fran" "charlie" } } [ first2 [ get ] 2apply parent-child ] each
-        [ { "adam" "eve" } ] [ "bob" get parents [ node-content ] map ] unit-test
+    [ { "bob" "fran" } ] [ "eve" get children [ 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" } ] [ "bob" get parents [ node-content ] map ] unit-test
-        [ { "adam" "eve" } ] [ "charlie" get get-root-nodes [ node-content ] map natural-sort >array ] 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" get "charlie" get tuck un-parent-child parents [ node-content ] map ] unit-test
+    [ { "adam" "eve" } ] [ "charlie" get get-root-nodes [ node-content ] map natural-sort >array ] unit-test
-    ] with-context
+    [ { } ] [ "fran" get "charlie" get tuck un-parent-child parents [ node-content ] map ] unit-test
 ] with-db
 
 delete-db