semantic-db: add RELATION:

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

@@ -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
+] with-db delete-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
+] with-db delete-db
-    ! [ { 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
 
 ! 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

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 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,11 +74,9 @@ 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 ;
 : has-context-relation 2 ;
@@ -66,7 +85,9 @@ arc "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 ;
+    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 ;
+    swapd delete-arcs ;
-
-: 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 ;
+    object-relation select-arc-subjects ;
-
-: 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 ;
+    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 ( member set in-set-relation -- arc-id ) create-arc ;
-: in-set* ( set member in-set-relation -- arc-id ) swapd create-arc ;
+: in-set? ( member set in-set-relation -- ? ) has-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 ;
+    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 ;