latest db and semantic-db (not really working)

extra/db/sqlite/sqlite.factor

@@ -22,7 +22,7 @@ M: sqlite-db db-close ( handle -- )
 M: sqlite-db dispose ( db -- ) dispose-db ;
 
 : with-sqlite ( path quot -- )
-    >r <sqlite-db> r> with-db ; inline
+    sqlite-db swap with-db ; inline
 
 : with-tmp-sqlite ( quot -- )
     ".db" [
@@ -33,10 +33,10 @@ TUPLE: sqlite-statement ;
 
 TUPLE: sqlite-result-set has-more? ;
 
-M: sqlite-db <simple-statement> ( str -- obj )
+M: sqlite-db <simple-statement> ( str in out -- obj )
     <prepared-statement> ;
 
-M: sqlite-db <prepared-statement> ( str -- obj )
+M: sqlite-db <prepared-statement> ( str in out -- obj )
     db get db-handle 
     {
         set-statement-sql
@@ -44,7 +44,7 @@ M: sqlite-db <prepared-statement> ( str -- obj )
         set-statement-out-params
         set-statement-handle
     } statement construct
-    dup statement-handle over statement-sql sqlite-prepare
+    dup statement-handle over statement-sql sqlite-prepare over set-statement-handle
     sqlite-statement construct-delegate ;
 
 M: sqlite-statement dispose ( statement -- )
@@ -86,7 +86,6 @@ M: sqlite-result-set more-rows? ( result-set -- ? )
     sqlite-result-set-has-more? ;
 
 M: sqlite-statement query-results ( query -- result-set )
-break
     dup statement-handle sqlite-result-set <result-set>
     dup advance-row ;
 

extra/db/tuples/tuples.factor

@@ -22,12 +22,6 @@ IN: db.tuples
         class db-columns find-primary-key sql-spec-slot-name
     ] keep set-slot-named ;
 
-! : primary-key-spec ( class -- spec )
-!     db-columns [ primary-key? ] find nip ;
-!     
-! : primary-key ( tuple -- obj )
-!     dup class primary-key-spec first swap get-slot-named ;
-
 ! returns a sequence of prepared-statements
 HOOK: create-sql-statement db ( class -- obj )
 HOOK: drop-sql-statement db ( class -- obj )
@@ -81,6 +75,7 @@ HOOK: insert-tuple* db ( tuple statement -- )
     [ bind-tuple ] keep execute-statement ;
 
 : insert-tuple ( tuple -- )
+    break
     dup class db-columns find-primary-key assigned-id? [
         insert-assigned
     ] [

extra/semantic-db/db/db.factor

@@ -35,7 +35,7 @@ M: sequence bindings
 
 : 1result ( array -- result )
     #! return the first (and hopefully only) element of the array, or f
-    dup length 0 > [ first ] [ drop f ] if ;
+    dup length zero? [ drop f ] [ first ] if ;
 
 : (collect-int-columns) ( statement n -- )
     [ dupd column-int , ] each drop ;

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

@@ -1,7 +1,9 @@
-USING: accessors db db.sqlite db.tuples kernel semantic-db tools.test ;
+USING: accessors db db.sqlite db.tuples kernel math semantic-db semantic-db.type tools.test ;
 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
@@ -9,3 +11,9 @@ IN: temporary
     [ 4 ] [ f create-node ] unit-test
     [ 5 ] [ 1 2 3 create-arc ] unit-test
 ] with-tmp-sqlite
+
+[
+    init-semantic-db
+    [ t ] [ "content" ensure-type "this is some content" ensure-node-of-type integer? ] unit-test
+    [ t ] [ "content" select-node-of-type integer? ]
+] with-tmp-sqlite

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 db db.tuples db.types db.sqlite kernel new-slots sequences ;
+USING: accessors arrays db db.tuples db.types db.sqlite kernel math new-slots sequences ;
 IN: semantic-db
 
 ! new semantic-db using Doug Coleman's new db abstraction library
@@ -11,7 +11,7 @@ TUPLE: node id content ;
 
 node "node"
 {
-    { "id" "id" SERIAL +native-id+ +autoincrement+ }
+    { "id" "id" +native-id+ +autoincrement+ }
     { "content" "content" TEXT }
 } define-persistent
 
@@ -19,7 +19,7 @@ node "node"
     node create-table ;
 
 : create-node ( content -- id )
-    <node> dup persist id>> ;
+    <node> dup insert-tuple id>> ;
 
 TUPLE: arc relation subject object ;
 
@@ -30,10 +30,10 @@ TUPLE: arc relation subject object ;
 
 arc "arc"
 {
-    { "id" "id" SERIAL +native-id+ } ! foreign key to node table?
+    { "id" "id" INTEGER } ! foreign key to node table?
-    { "relation" "relation" SERIAL +not-null+ }
+    { "relation" "relation" INTEGER +not-null+ }
-    { "subject" "subject" SERIAL +not-null+ }
+    { "subject" "subject" INTEGER +not-null+ }
-    { "object" "object" SERIAL +not-null+ }
+    { "object" "object" INTEGER +not-null+ }
 } define-persistent
 
 : create-arc-table ( -- )
@@ -41,34 +41,48 @@ arc "arc"
 
 : insert-arc ( arc -- )
     dup delegate insert-tuple
-    [ ] [ insert-sql ] make-tuple-statement insert-statement drop ;
+    insert-tuple ;
+   ! [ ] [ insert-sql ] make-tuple-statement insert-statement drop ;
 
-: persist-arc ( arc -- )
+! : insert-arc ( arc -- )
-    dup primary-key [ update-tuple ] [ insert-arc ] if ;
+!     dup primary-key [ update-tuple ] [ insert-arc ] if ;
 
 : delete-arc ( arc -- )
     dup delete-tuple delegate delete-tuple ;
 
 : create-arc ( relation subject object -- id )
-    <arc> dup persist-arc id>> ;
+    <arc> dup insert-arc id>> ;
 
 : create-bootstrap-nodes ( -- )
-    { "context" "relation" "is of type" "semantic-db" "is in context" }
+    { "context" "type" "relation" "is of type" "semantic-db" "is in context" }
     [ create-node drop ] each ;
 
+! TODO: maybe put these in a 'special nodes' table
 : context-type 1 ; inline
-: relation-type 2 ; inline
+: type-type 2 ; inline
-: has-type-relation 3 ; inline
+: relation-type 3 ; inline
-: semantic-db-context 4 ; inline
+: has-type-relation 4 ; inline
-: has-context-relation 5 ; inline
+: semantic-db-context 5 ; inline
+: has-context-relation 6 ; inline
 
 : create-bootstrap-arcs ( -- )
+    ! give everything a type
+    has-type-relation context-type type-type create-arc drop
+    has-type-relation type-type type-type create-arc drop
+    has-type-relation relation-type type-type create-arc drop
     has-type-relation has-type-relation relation-type create-arc drop
     has-type-relation semantic-db-context context-type create-arc drop
-    has-context-relation has-type-relation semantic-db-context create-arc drop
     has-type-relation has-context-relation relation-type create-arc drop
+    ! give relations a context (semantic-db context)
+    has-context-relation has-type-relation semantic-db-context create-arc drop
     has-context-relation has-context-relation semantic-db-context create-arc drop ;
 
 : 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 ;

extra/semantic-db/type/type.factor

@@ -1,19 +1,42 @@
 ! Copyright (C) 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel semantic-db ;
+USING: arrays db db.types kernel semantic-db ;
 IN: semantic-db.type
 
 : assign-type ( type nid -- arc-id )
     has-type-relation spin create-arc ;
 
-: create-node-of-type ( type name -- node-id )
+: create-node-of-type ( type content -- node-id )
     create-node [ assign-type drop ] keep ;
 
-: select-node-of-type ( type name -- node-id? )
+: select-nodes-of-type ( type -- node-ids )
-    ! find a node with the given name, that is the subject of an arc with:
+    "type" INTEGER param
+    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 ;
+
+: select-node-of-type ( type -- node-id )
+    select-nodes-of-type 1array ;
+
+: 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
+    swap "type" INTEGER param
+    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 ;
 
-: ensure-node-of-type ( type name -- node-id )
+: 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* ;
+
+: ensure-type ( type -- node-id )
+    dup "type" = [
+        drop type-type
+    ] [
+        type-type swap ensure-node-of-type
+    ] if ;