experimental semantic-db before a major change
Alex Chapman
parent
fd79a5f623
commit
4222b6299b
|
|
@ -3,12 +3,17 @@
|
|||
USING: kernel semantic-db semantic-db.type ;
|
||||
IN: semantic-db.context
|
||||
|
||||
! : all-contexts ( -- contexts )
|
||||
! has-type-relation context-type relation-object-subjects ;
|
||||
!
|
||||
! : context-relations ( context -- relations )
|
||||
! has-context-relation swap relation-object-subjects ;
|
||||
! contexts:
|
||||
! - have type 'context' in context 'semantic-db'
|
||||
|
||||
: 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 ;
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
! type = relation (in semantic-db context)
|
||||
! context = hierarchy
|
||||
! name = "has parent"
|
||||
hierarchy-context "has parent" relation-id ;
|
||||
|
||||
: parent-of ( parent child -- arc-id )
|
||||
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> ;
|
||||
|
|
|
|||
|
|
@ -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* ;
|
||||
|
|
@ -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
|
||||
[ t ] [ "content" select-node-of-type integer? ]
|
||||
type-type 1array [ "type" ensure-type ] unit-test
|
||||
[ { 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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
f <node> over set-delegate
|
||||
swap >>object swap >>subject swap >>relation ;
|
||||
arc construct-empty 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
|
||||
insert-tuple ;
|
||||
! [ ] [ insert-sql ] make-tuple-statement insert-statement drop ;
|
||||
|
||||
! : insert-arc ( arc -- )
|
||||
! dup primary-key [ update-tuple ] [ insert-arc ] if ;
|
||||
f <node> dup insert-tuple id>> >>id insert-tuple ;
|
||||
|
||||
: 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
|
||||
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-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 ;
|
||||
context-type type-type has-type-in-semantic-db
|
||||
type-type type-type has-type-in-semantic-db
|
||||
relation-type type-type has-type-in-semantic-db
|
||||
has-type-relation relation-type has-type-in-semantic-db
|
||||
semantic-db-context context-type has-type-in-semantic-db
|
||||
has-context-relation relation-type has-type-in-semantic-db
|
||||
! give relations and types the semantic-db context
|
||||
context-type has-semantic-db-context
|
||||
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* ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
has-type-relation "has_type" INTEGER param 2array
|
||||
":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 ;
|
||||
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
|
||||
swap "type" INTEGER param
|
||||
has-type-relation "has_type" INTEGER param 3array
|
||||
":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 ;
|
||||
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" = [
|
||||
|
|
|
|||
Loading…
Reference in New Issue