experimental semantic-db before a major change

extra/semantic-db/context/context.factor

@@ -3,12 +3,17 @@
 USING: kernel semantic-db semantic-db.type ;
 IN: semantic-db.context
 
-! : all-contexts ( -- contexts )
+! contexts:
-!     has-type-relation context-type relation-object-subjects ;
+!  - have type 'context' in context 'semantic-db'
-! 
-! : context-relations ( context -- relations )
-!     has-context-relation swap relation-object-subjects ;
 
-: ensure-context ( name -- context-id )
+: current-context ( -- context-id )
+    \ current-context get ;
+
+: set-current-context ( context-id -- )
+    \ current-context set ;
+
+: context-id ( name -- context-id )
     context-type swap ensure-node-of-type ;
 
+: with-context ( name quot -- )
+    swap context-id [ set-current-context ] curry swap compose with-scope ;

extra/semantic-db/hierarchy/hierarchy.factor

@@ -1,19 +1,27 @@
 ! Copyright (C) 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel new-slots semantic-db semantic-db.context sequences ;
+USING: accessors kernel new-slots semantic-db semantic-db.relations sequences ;
 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" ensure-context ;
+    "hierarchy" context-id ;
 
 : has-parent-relation ( -- relation-id )
-    ! find an arc with:
+    hierarchy-context "has parent" relation-id ;
-    !   type = relation (in semantic-db context)
+
-    !   context = hierarchy
+: parent-of ( parent child -- arc-id )
-    !   name = "has parent"
+    has-parent-relation spin create-arc ;
+
+: select-parents ( child -- parents )
+
+
+: ensure-parent ( child parent -- )
+    ! TODO
     ;
 
 : find-children ( node-id -- children )
@@ -21,7 +29,10 @@ C: <tree> tree
     !   relation = has-parent-relation
     !   object = node-id
     ! then load the subjects either as nodes or subtrees
-    ;
+    ":node_id" INTEGER param
+    has-parent-relation ":has_parent" INTEGER param 2array
+    "select a.subject from arc a where relation = :has_parent and object = :node_id"
+    single-int-results ;
 
 : get-node-hierarchy ( node-id -- tree )
     dup find-children <tree> ;

extra/semantic-db/relations/relations.factor

@@ -0,0 +1,27 @@
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel semantic-db semantic-db.context semantic-db.type ;
+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 )
+    relation-type swap ensure-node-of-type
+    tuck has-context-relation spin create-arc ;
+
+: select-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"
+    single-int-results ;
+
+: relation-id ( context-id relation-name -- relation-id )
+    [ select-relation ] [ create-relation ] ensure2 ;
+    ! 2dup select-relation [ 2nip ] [ create-relation ] if* ;

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

@@ -1,9 +1,7 @@
-USING: accessors db db.sqlite db.tuples kernel math semantic-db semantic-db.type tools.test ;
+USING: accessors arrays db db.sqlite db.tuples kernel math semantic-db semantic-db.type sequences tools.test tools.walker ;
 IN: temporary
 
 [
-USE: tools.walker
-break
     create-node-table create-arc-table
     [ 1 ] [ "first node" create-node ] unit-test
     [ 2 ] [ "second node" create-node ] unit-test
@@ -14,6 +12,15 @@ break
 
 [
     init-semantic-db
-    [ t ] [ "content" ensure-type "this is some content" ensure-node-of-type integer? ] unit-test
+    type-type 1array [ "type" ensure-type ] unit-test
-    [ t ] [ "content" select-node-of-type integer? ]
+    [ { 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

extra/semantic-db/semantic-db.factor

@@ -1,10 +1,8 @@
 ! Copyright (C) 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays db db.tuples db.types db.sqlite kernel math new-slots sequences ;
+USING: accessors arrays continuations db db.tuples db.types db.sqlite kernel math math.parser new-slots sequences ;
 IN: semantic-db
 
-! new semantic-db using Doug Coleman's new db abstraction library
-
 TUPLE: node id content ;
 : <node> ( content -- node )
     node construct-empty swap >>content ;
@@ -21,16 +19,14 @@ node "node"
 : create-node ( content -- id )
     <node> dup insert-tuple id>> ;
 
-TUPLE: arc relation subject object ;
+TUPLE: arc id relation subject object ;
 
 : <arc> ( relation subject object -- arc )
-    arc construct-empty
+    arc construct-empty swap >>object swap >>subject swap >>relation ;
-    f <node> over set-delegate
-    swap >>object swap >>subject swap >>relation ;
 
 arc "arc"
 {
-    { "id" "id" INTEGER } ! foreign key to node table?
+    { "id" "id" INTEGER +assigned-id+ } ! foreign key to node table?
     { "relation" "relation" INTEGER +not-null+ }
     { "subject" "subject" INTEGER +not-null+ }
     { "object" "object" INTEGER +not-null+ }
@@ -40,12 +36,7 @@ arc "arc"
     arc create-table ;
 
 : insert-arc ( arc -- )
-    dup delegate insert-tuple
+    f <node> dup insert-tuple id>> >>id insert-tuple ;
-    insert-tuple ;
-   ! [ ] [ insert-sql ] make-tuple-statement insert-statement drop ;
-
-! : insert-arc ( arc -- )
-!     dup primary-key [ update-tuple ] [ insert-arc ] if ;
 
 : delete-arc ( arc -- )
     dup delete-tuple delegate delete-tuple ;
@@ -54,7 +45,7 @@ arc "arc"
     <arc> dup insert-arc id>> ;
 
 : create-bootstrap-nodes ( -- )
-    { "context" "type" "relation" "is of type" "semantic-db" "is in context" }
+    { "context" "type" "relation" "has type" "semantic-db" "has context" }
     [ create-node drop ] each ;
 
 ! TODO: maybe put these in a 'special nodes' table
@@ -65,24 +56,38 @@ arc "arc"
 : 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-type-relation context-type type-type create-arc drop
+    context-type type-type has-type-in-semantic-db
-    has-type-relation type-type type-type create-arc drop
+    type-type type-type has-type-in-semantic-db
-    has-type-relation relation-type type-type create-arc drop
+    relation-type type-type has-type-in-semantic-db
-    has-type-relation has-type-relation relation-type create-arc drop
+    has-type-relation relation-type has-type-in-semantic-db
-    has-type-relation semantic-db-context context-type create-arc drop
+    semantic-db-context context-type has-type-in-semantic-db
-    has-type-relation has-context-relation relation-type create-arc drop
+    has-context-relation relation-type has-type-in-semantic-db
-    ! give relations a context (semantic-db context)
+    ! give relations and types the semantic-db context
-    has-context-relation has-type-relation semantic-db-context create-arc drop
+    context-type has-semantic-db-context
-    has-context-relation has-context-relation semantic-db-context create-arc drop ;
+    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 ;
 
-: 1result ( array -- result )
-    #! return the first (and hopefully only) element of the array, or f
-    dup length zero? [ drop f ] [ first ] if ;
-
 : param ( value key type -- param )
-    rot 3array ;
+    swapd 3array ;
+
+: single-int-results ( bindings sql -- array )
+    f f <simple-statement> [ do-bound-query ] with-disposal
+    [ first string>number ] map ;
+
+: ensure2 ( x y quot1 quot2 -- z )
+    #! quot1 ( x y -- z/f ) finds an existing z
+    #! quot2 ( x y -- z ) creates a new z if quot1 returns f
+    >r >r 2dup r> call [ 2nip ] r> if* ;

extra/semantic-db/type/type.factor

@@ -1,8 +1,12 @@
 ! Copyright (C) 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays db db.types kernel semantic-db ;
+USING: arrays db db.types kernel semantic-db sequences sequences.lib ;
 IN: semantic-db.type
 
+! types:
+!  - have type 'type' in context 'semantic-db'
+!  - have a context in context 'semantic-db'
+
 : assign-type ( type nid -- arc-id )
     has-type-relation spin create-arc ;
 
@@ -10,29 +14,31 @@ IN: semantic-db.type
     create-node [ assign-type drop ] keep ;
 
 : select-nodes-of-type ( type -- node-ids )
-    "type" INTEGER param
+    ":type" INTEGER param
-    has-type-relation "has_type" INTEGER param 2array
+    has-type-relation ":has_type" INTEGER param 2array
     "select a.subject from arc a where a.relation = :has_type and a.object = :type"
-    <prepared-statement> do-bound-query ;
+    single-int-results ;
 
 : select-node-of-type ( type -- node-id )
-    select-nodes-of-type 1array ;
+    select-nodes-of-type ?first ;
 
 : select-nodes-of-type-with-content ( type content -- node-ids )
     ! find nodes with the given content that are the subjects of arcs with:
     !     relation = has-type-relation
     !     object = type
-    "name" TEXT param
+    ":name" TEXT param
-    swap "type" INTEGER param
+    swap ":type" INTEGER param
-    has-type-relation "has_type" INTEGER param 3array
+    has-type-relation ":has_type" INTEGER param 3array
     "select n.id from node n, arc a where n.content = :name and n.id = a.subject and a.object = :type and a.relation = :has_type"
-    <prepared-statement> do-bound-query ;
+    single-int-results ;
 
 : select-node-of-type-with-content ( type content -- node-id/f )
     select-nodes-of-type-with-content 1result ;
 
 : ensure-node-of-type ( type content -- node-id )
-    2dup select-node-of-type [ 2nip ] [ create-node-of-type ] if* ;
+    [ select-node-of-type-with-content ] [ create-node-of-type ] ensure2 ;
+    ! 2dup select-node-of-type-with-content [ 2nip ] [ create-node-of-type ] if* ;
+
 
 : ensure-type ( type -- node-id )
     dup "type" = [