semantic-db: pass around node objects instead of ids

diff --git a/extra/semantic-db/semantic-db-tests.factor b/extra/semantic-db/semantic-db-tests.factor
index 7fa0ff2176385e78881dde3f43a83f767c39cb98..ac620de4d9b00cff2cb00445fbd6b68bf2f6c130 100644 (file)
--- a/extra/semantic-db/semantic-db-tests.factor
+++ b/extra/semantic-db/semantic-db-tests.factor
@@ -1,7 +1,6 @@
 USING: accessors arrays continuations db db.sqlite db.tuples io.files
-kernel math namespaces semantic-db
-
-sequences sorting tools.test tools.walker ;
+kernel math namespaces semantic-db sequences sorting tools.test
+tools.walker ;
 IN: semantic-db.tests
 
 SYMBOL: context
@@ -14,32 +13,34 @@ delete-db
 
 test-db [
     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
+    [ 1 ] [ "first node" create-node id>> ] unit-test
+    [ 2 ] [ "second node" create-node id>> ] unit-test
+    [ 3 ] [ "third node" create-node id>> ] unit-test
+    [ 4 ] [ f create-node id>> ] unit-test
+    [ ] [ 1 f <node> 2 f <node> 3 f <node> create-arc ] unit-test
 ] with-db delete-db
 
  test-db [
      init-semantic-db
      "test content" create-context context set
-     [ 4 ] [ context get ] unit-test
-     [ 5 ] [ "is test content" context get create-relation ] unit-test
-     [ 5 ] [ "is test content" context get get-relation ] unit-test
-     [ 5 ] [ "is test content" context get relation-id ] unit-test
-     [ 7 ] [ "has parent" context get relation-id ] unit-test
-     [ 7 ] [ "has parent" context get relation-id ] unit-test
-     [ "has parent" ] [ "has parent" context get relation-id node-content ] unit-test
+     [ T{ node f 3 "test content" } ] [ context get ] unit-test
+     [ T{ node f 4 "is test content" } ] [ "is test content" context get create-relation ] unit-test
+     [ T{ node f 4 "is test content" } ] [ "is test content" context get get-relation ] unit-test
+     [ T{ node f 4 "is test content" } ] [ "is test content" context get ensure-relation ] unit-test
+     [ T{ node f 5 "has parent" } ] [ "has parent" context get ensure-relation ] unit-test
+     [ T{ node f 5 "has parent" } ] [ "has parent" context get ensure-relation ] unit-test
+     [ "has parent" ] [ "has parent" context get ensure-relation node-content ] unit-test
      [ "test content" ] [ context get node-content ] unit-test
  ] with-db delete-db
  
- ! "test1" f f f f f <relation-definition> define-relation
+ ! "test1" "test1-relation-id-word" f f f f <relation-definition> define-relation
  ! "test2" t t t t t <relation-definition> define-relation
- RELATION: test
+ RELATION: test3
  test-db [
      init-semantic-db
-     [ 5 ] [ test-relation ] unit-test
+     ! [ T{ node f 3 "test1" } ] [ test1-relation-id-word ] unit-test
+     ! [ T{ node f 4 "test2" } ] [ test2-relation ] unit-test
+     [ T{ node f 4 "test3" } ] [ test3-relation ] unit-test
  ] with-db delete-db
  
  ! test hierarchy
@@ -52,12 +53,14 @@ test-db [
      "fran" create-node "fran" set
      "charlie" create-node "charlie" set
      "gertrude" create-node "gertrude" set
-      [ t ] [ "bob" get "adam" get has-parent integer? ] unit-test
-     { { "bob" "eve" } { "fran" "eve" } { "gertrude" "bob" } { "fran" "bob" } { "charlie" "fran" } } [ first2 [ get ] 2apply has-parent drop ] each
+      [ ] [ "bob" get "adam" get has-parent ] unit-test
+     { { "bob" "eve" } { "fran" "eve" } { "gertrude" "bob" } { "fran" "bob" } { "charlie" "fran" } } [ first2 [ get ] 2apply has-parent ] each
      [ { "bob" "fran" } ] [ "eve" get has-parent-relation children [ node-content ] map ] unit-test
      [ { "adam" "eve" } ] [ "bob" get has-parent-relation parents [ node-content ] map ] unit-test
-     [ "fran" { "charlie" } ] [ "fran" get has-parent-relation 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-node-hierarchy dup node>> node-content swap children>> [ node>> node-content ] map ] unit-test
      [ { "adam" "eve" } ] [ "charlie" get has-parent-relation get-root-nodes [ node-content ] map natural-sort >array ] unit-test
      [ { } ] [ "charlie" get dup "fran" get !has-parent has-parent-relation parents [ node-content ] map ] unit-test
+     [ { "adam" "eve" } ] [ has-parent-relation ultimate-objects node-results [ node-content ] map ] unit-test
+     [ { "fran" "gertrude" } ] [ has-parent-relation ultimate-subjects node-results [ node-content ] map ] unit-test
  ] with-db delete-db
  

diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor
index ee276260f3fe7c573a446edca3d237abd20d74cd..2500441b110f904c24b9d5babb7c03d7c8bedf55 100755 (executable)
--- a/extra/semantic-db/semantic-db.factor
+++ b/extra/semantic-db/semantic-db.factor
@@ -1,14 +1,13 @@
 ! Copyright (C) 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays combinators combinators.cleave continuations db db.tuples db.types db.sqlite hashtables kernel math math.parser namespaces new-slots parser sequences sequences.deep sequences.lib strings words ;
+USING: accessors arrays combinators combinators.cleave combinators.lib
+continuations db db.tuples db.types db.sqlite hashtables kernel math
+math.parser namespaces parser sequences sequences.deep
+sequences.lib strings words ;
 IN: semantic-db
 
 TUPLE: node id content ;
-: <node> ( content -- node )
-    node construct-empty swap >>content ;
-
-: <id-node> ( id -- node )
-    node construct-empty swap >>id ;
+C: <node> node
 
 node "node"
 {
@@ -16,15 +15,14 @@ node "node"
     { "content" "content" TEXT }
 } define-persistent
 
-: delete-node ( node-id -- )
-    <id-node> delete-tuple ;
-
-: create-node ( str -- node-id )
-    <node> dup insert-tuple id>> ;
+: delete-node ( node -- ) delete-tuple ;
+: create-node ( content -- node ) f swap <node> dup insert-tuple ;
+: load-node ( id -- node ) f <node> select-tuple ;
 
-: node-content ( id -- str )
-    <id-node> select-tuple content>> ;
+: node-content ( node -- content )
+    dup content>> [ nip ] [ select-tuple content>> ] if* ;
 
+! TODO: get rid of arc id and write our own sql
 TUPLE: arc id subject object relation ;
 
 : <arc> ( subject object relation -- arc )
@@ -33,42 +31,50 @@ TUPLE: arc id subject object 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 -- ) delete-tuple ;
 
-: delete-arc ( arc-id -- )
-    dup delete-node <id-arc> delete-tuple ;
+: create-arc ( subject object relation -- )
+    [ id>> ] 3apply <arc> insert-tuple ;
 
-: create-arc ( subject object relation -- arc-id )
-    <arc> dup insert-arc id>> ;
-
-: has-arc? ( subject object relation -- ? )
-    <arc> select-tuples length 0 > ;
+: nodes>arc ( subject object relation -- arc )
+    [ [ id>> ] [ f ] if* ] 3apply <arc> ;
 
 : select-arcs ( subject object relation -- arcs )
-    <arc> select-tuples ;
+    nodes>arc select-tuples ;
+
+: has-arc? ( subject object relation -- ? )
+    select-arcs length 0 > ;
 
-: select-arc-ids ( subject object relation -- arc-ids )
-    select-arcs [ id>> ] map ;
+: select-arc-subjects ( subject object relation -- subjects )
+    select-arcs [ subject>> f <node> ] map ;
 
-: select-arc-subjects ( subject object relation -- subject-ids )
-    select-arcs [ subject>> ] map ;
+: select-arc-subject ( subject object relation -- subject )
+    select-arcs ?first [ subject>> f <node> ] [ f ] if* ;
 
-: select-subjects ( object relation -- subject-ids )
+: select-subjects ( object relation -- subjects )
     f -rot select-arc-subjects ;
 
-: select-arc-objects ( subject object relation -- object-ids )
-    select-arcs [ object>> ] map ;
+: select-subject ( object relation -- subject )
+    f -rot select-arc-subject ;
+
+: select-arc-objects ( subject object relation -- objects )
+    select-arcs [ object>> f <node> ] map ;
+
+: select-arc-object ( subject object relation -- object )
+    select-arcs ?first [ object>> f <node> ] [ f ] if* ;
 
-: select-objects ( subject relation -- object-ids )
+: select-objects ( subject relation -- objects )
     f swap select-arc-objects ;
 
+: select-object ( subject relation -- object )
+    f swap select-arc-object ;
+
 : delete-arcs ( subject object relation -- )
-    select-arcs [ id>> delete-arc ] each ;
+    select-arcs [ delete-arc ] each ;
 
 arc "arc"
 {
-    { "id" "id" INTEGER +assigned-id+ } ! foreign key to node table?
+    { "id" "id" +native-id+ +autoincrement+ }
     { "relation" "relation" INTEGER +not-null+ }
     { "subject" "subject" INTEGER +not-null+ }
     { "object" "object" INTEGER +not-null+ }
@@ -78,66 +84,99 @@ arc "arc"
     "semantic-db" create-node drop
     "has-context" create-node drop ;
 
-: semantic-db-context  1 ;
-: has-context-relation 2 ;
+: semantic-db-context  T{ node f 1 "semantic-db" } ;
+: has-context-relation T{ node f 2 "has-context" } ;
 
 : create-bootstrap-arcs ( -- )
-    has-context-relation semantic-db-context has-context-relation create-arc drop ;
+    has-context-relation semantic-db-context has-context-relation create-arc ;
 
 : init-semantic-db ( -- )
-    node create-table
-    arc create-table
+    node create-table arc create-table
     create-bootstrap-nodes create-bootstrap-arcs ;
 
-: param ( value key type -- param )
-    swapd 3array ;
+: param ( value key type -- param ) swapd 3array ;
 
-: single-int-results ( bindings sql -- array )
-    f f <simple-statement> [ do-bound-query ] with-disposal
-    [ first string>number ] map ;
+! db utilities
+: results ( bindings sql -- array )
+    f f <simple-statement> [ do-bound-query ] with-disposal ;
 
-: 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* ;
+: node-result ( result -- node )
+    dup first string>number swap second <node> ;
 
-: ensure2 ( x y quot1 quot2 -- 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* ;
+: ?1node-result ( results -- node )
+    ?first [ node-result ] [ f ] 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 ;
+: node-results ( results -- nodes )
+    [ node-result ] map ;
+
+: subjects-with-cor ( content object relation -- sql-results )
+    [ id>> ] 2apply
+    [
+        ":relation" INTEGER param ,
+        ":object" INTEGER param ,
+        ":content" TEXT param ,
+    ] { } make
+    "select n.id, n.content from node n, arc a where n.content = :content and n.id = a.subject and a.relation = :relation and a.object = :object" results ;
 
-: get-context ( context-name -- context-id/f )
+: objects-with-csr ( content subject relation -- sql-results )
+    [ id>> ] 2apply
     [
-        ":name" TEXT param ,
-        has-context-relation ":has_context" INTEGER param ,
+        ":relation" INTEGER param ,
+        ":subject" INTEGER param ,
+        ":content" TEXT 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 ;
+    "select n.id, n.content from node n, arc a where n.content = :content and n.id = a.object and a.relation = :relation and a.subject = :subject" results ;
 
-: context-id ( context-name -- context-id )
-    [ get-context ] [ create-context ] ensure1 ;
+: (with-relation) ( content relation -- bindings sql )
+    id>> [ ":relation" INTEGER param , ":content" TEXT param , ] { } make
+    "select distinct n.id, n.content from node n, arc a where n.content = :content and a.relation = :relation" ;
+
+: subjects-with-relation ( content relation -- sql-results )
+    (with-relation) " and a.object = n.id" append results ;
+
+: objects-with-relation ( content relation -- sql-results )
+    (with-relation) " and a.subject = n.id" append results ;
+
+: (ultimate) ( relation b a -- sql-results )
+    [
+        "select distinct n.id, n.content from node n, arc a where a.relation = :relation and n.id = a." % % " and n.id not in (select b." % % " from arc b where b.relation = :relation)" %
+    ] "" make [ id>> ":relation" INTEGER param 1array ] dip results ;
+
+: ultimate-objects ( relation -- sql-results )
+    "subject" "object" (ultimate) ;
+
+: ultimate-subjects ( relation -- sql-results )
+    "object" "subject" (ultimate) ;
+
+! contexts:
+!  - a node n is a context iff there exists a relation r such that r has context n
+: create-context ( context-name -- context ) create-node ;
+
+: get-context ( context-name -- context/f )
+    has-context-relation subjects-with-relation ?1node-result ;
+
+: ensure-context ( context-name -- context )
+    dup get-context [
+        nip
+    ] [
+        create-context
+    ] if* ;
 
 ! 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 ;
+: create-relation ( relation-name context -- relation )
+    [ create-node dup ] dip has-context-relation create-arc ;
 
-: 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 ;
+: get-relation ( relation-name context -- relation/f )
+    has-context-relation subjects-with-cor ?1node-result ;
 
-: relation-id ( relation-name context-id -- relation-id )
-    [ get-relation ] [ create-relation ] ensure2 ;
+: ensure-relation ( relation-name context -- relation )
+    2dup get-relation [
+        2nip
+    ] [
+        create-relation
+    ] if* ;
 
 TUPLE: relation-definition relate id-word unrelate related? subjects objects ;
 C: <relation-definition> relation-definition
@@ -181,7 +220,7 @@ C: <relation-definition> relation-definition
 
 : define-id-word ( relation-definition id-word -- )
     [ relate>> ] dip tuck word-vocabulary
-    [ context-id relation-id ] 2curry define ;
+    [ ensure-context ensure-relation ] 2curry define ;
 
 : create-id-word ( relation-definition -- id-word )
     dup id-word>> "id-word" choose-word-name create-in ;
@@ -195,22 +234,46 @@ PRIVATE>
     scan t t t t t <relation-definition> define-relation ; parsing
 
 ! hierarchy
-TUPLE: tree id children ;
-C: <tree> tree
+TUPLE: node-tree node children ;
+C: <node-tree> node-tree
+
+: children ( node has-parent-relation -- children ) select-subjects ;
+: parents ( node has-parent-relation -- parents ) select-objects ;
+
+: get-node-tree ( node child-selector -- node-tree )
+    2dup call >r [ get-node-tree ] curry r> swap map <node-tree> ;
+
+! : get-node-tree ( node has-parent-relation -- node-tree )
+!     2dup children >r [ get-node-tree ] curry r> swap map <node-tree> ;
+: get-node-tree-s ( node has-parent-relation -- tree )
+    [ select-subjects ] curry get-node-tree ;
+
+: get-node-tree-o ( node has-child-relation -- tree )
+    [ select-objects ] curry get-node-tree ;
+
+: (get-node-chain) ( node next-selector seq -- seq )
+    pick [
+        over push >r [ call ] keep r> (get-node-chain)
+    ] [
+        2nip
+    ] if* ;
+
+: get-node-chain ( node next-selector -- seq )
+    V{ } clone (get-node-chain) ;
 
-: children ( node-id has-parent-relation -- children ) select-subjects ;
-: parents ( node-id has-parent-relation -- parents ) select-objects ;
+: get-node-chain-o ( node relation -- seq )
+    [ select-object ] curry get-node-chain ;
 
-: get-node-hierarchy ( node-id has-parent-relation -- tree )
-    2dup children >r [ get-node-hierarchy ] curry r> swap map <tree> ;
+: get-node-chain-s ( node relation -- seq )
+    [ select-subject ] curry get-node-chain ;
 
-: (get-root-nodes) ( node-id has-parent-relation -- root-nodes/node-id )
+: (get-root-nodes) ( node has-parent-relation -- root-nodes/node )
     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 ( node has-parent-relation -- root-nodes )
     (get-root-nodes) flatten prune ;