steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

latest db and semantic-db (not really working)

db4
Alex Chapman 2008-02-29 13:51:59 +11:00
parent 44548d0d0e
commit 0da202f178
6 changed files with 75 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
extra/db/sqlite/sqlite.factor
View File

@ -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 ;

7
extra/db/tuples/tuples.factor
View File

@ -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
] [

2
extra/semantic-db/db/db.factor
View File

@ -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 ;

10
extra/semantic-db/semantic-db-tests.factor
View File

@ -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

48
extra/semantic-db/semantic-db.factor
View File

@ -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?
{ "relation" "relation" SERIAL +not-null+ }
{ "subject" "subject" SERIAL +not-null+ }
{ "object" "object" SERIAL +not-null+ }
{ "id" "id" INTEGER } ! foreign key to node table?
{ "relation" "relation" INTEGER +not-null+ }
{ "subject" "subject" INTEGER +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 -- )
dup primary-key [ update-tuple ] [ insert-arc ] if ;
! : insert-arc ( arc -- )
! 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
: has-type-relation 3 ; inline
: semantic-db-context 4 ; inline
: has-context-relation 5 ; inline
: type-type 2 ; inline
: relation-type 3 ; inline
: has-type-relation 4 ; 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 ;

35
extra/semantic-db/type/type.factor
View File

@ -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? )
! find a node with the given name, that is the subject of an arc with:
: select-nodes-of-type ( type -- node-ids )
"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 ;