experimental semantic-db before a major change
parent
fd79a5f623
commit
4222b6299b
|
@ -3,12 +3,17 @@
|
||||||
USING: kernel semantic-db semantic-db.type ;
|
USING: kernel semantic-db semantic-db.type ;
|
||||||
IN: semantic-db.context
|
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 ;
|
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
|
! Copyright (C) 2008 Alex Chapman
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! 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
|
IN: semantic-db.hierarchy
|
||||||
|
|
||||||
TUPLE: tree id children ;
|
TUPLE: tree id children ;
|
||||||
C: <tree> tree
|
C: <tree> tree
|
||||||
|
|
||||||
|
! TODO: don't use context here. Hierarchies should be created within
|
||||||
|
! arbitrary contexts.
|
||||||
: hierarchy-context ( -- context-id )
|
: hierarchy-context ( -- context-id )
|
||||||
"hierarchy" ensure-context ;
|
"hierarchy" context-id ;
|
||||||
|
|
||||||
: has-parent-relation ( -- relation-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 )
|
: find-children ( node-id -- children )
|
||||||
|
@ -21,7 +29,10 @@ C: <tree> tree
|
||||||
! relation = has-parent-relation
|
! relation = has-parent-relation
|
||||||
! object = node-id
|
! object = node-id
|
||||||
! then load the subjects either as nodes or subtrees
|
! 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 )
|
: get-node-hierarchy ( node-id -- tree )
|
||||||
dup find-children <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
|
IN: temporary
|
||||||
|
|
||||||
[
|
[
|
||||||
USE: tools.walker
|
|
||||||
break
|
|
||||||
create-node-table create-arc-table
|
create-node-table create-arc-table
|
||||||
[ 1 ] [ "first node" create-node ] unit-test
|
[ 1 ] [ "first node" create-node ] unit-test
|
||||||
[ 2 ] [ "second node" create-node ] unit-test
|
[ 2 ] [ "second node" create-node ] unit-test
|
||||||
|
@ -14,6 +12,15 @@ break
|
||||||
|
|
||||||
[
|
[
|
||||||
init-semantic-db
|
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
|
] with-tmp-sqlite
|
||||||
|
|
|
@ -1,10 +1,8 @@
|
||||||
! Copyright (C) 2008 Alex Chapman
|
! Copyright (C) 2008 Alex Chapman
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! 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
|
IN: semantic-db
|
||||||
|
|
||||||
! new semantic-db using Doug Coleman's new db abstraction library
|
|
||||||
|
|
||||||
TUPLE: node id content ;
|
TUPLE: node id content ;
|
||||||
: <node> ( content -- node )
|
: <node> ( content -- node )
|
||||||
node construct-empty swap >>content ;
|
node construct-empty swap >>content ;
|
||||||
|
@ -21,16 +19,14 @@ node "node"
|
||||||
: create-node ( content -- id )
|
: create-node ( content -- id )
|
||||||
<node> dup insert-tuple id>> ;
|
<node> dup insert-tuple id>> ;
|
||||||
|
|
||||||
TUPLE: arc relation subject object ;
|
TUPLE: arc id relation subject object ;
|
||||||
|
|
||||||
: <arc> ( relation subject object -- arc )
|
: <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"
|
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+ }
|
{ "relation" "relation" INTEGER +not-null+ }
|
||||||
{ "subject" "subject" INTEGER +not-null+ }
|
{ "subject" "subject" INTEGER +not-null+ }
|
||||||
{ "object" "object" INTEGER +not-null+ }
|
{ "object" "object" INTEGER +not-null+ }
|
||||||
|
@ -40,12 +36,7 @@ arc "arc"
|
||||||
arc create-table ;
|
arc create-table ;
|
||||||
|
|
||||||
: insert-arc ( arc -- )
|
: 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 -- )
|
: delete-arc ( arc -- )
|
||||||
dup delete-tuple delegate delete-tuple ;
|
dup delete-tuple delegate delete-tuple ;
|
||||||
|
@ -54,7 +45,7 @@ arc "arc"
|
||||||
<arc> dup insert-arc id>> ;
|
<arc> dup insert-arc id>> ;
|
||||||
|
|
||||||
: create-bootstrap-nodes ( -- )
|
: 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 ;
|
[ create-node drop ] each ;
|
||||||
|
|
||||||
! TODO: maybe put these in a 'special nodes' table
|
! TODO: maybe put these in a 'special nodes' table
|
||||||
|
@ -65,24 +56,38 @@ arc "arc"
|
||||||
: semantic-db-context 5 ; inline
|
: semantic-db-context 5 ; inline
|
||||||
: has-context-relation 6 ; 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 ( -- )
|
: create-bootstrap-arcs ( -- )
|
||||||
! give everything a type
|
! 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 ( -- )
|
: init-semantic-db ( -- )
|
||||||
create-node-table create-arc-table create-bootstrap-nodes create-bootstrap-arcs ;
|
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 )
|
: 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
|
! Copyright (C) 2008 Alex Chapman
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! 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
|
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 )
|
: assign-type ( type nid -- arc-id )
|
||||||
has-type-relation spin create-arc ;
|
has-type-relation spin create-arc ;
|
||||||
|
|
||||||
|
@ -10,29 +14,31 @@ IN: semantic-db.type
|
||||||
create-node [ assign-type drop ] keep ;
|
create-node [ assign-type drop ] keep ;
|
||||||
|
|
||||||
: select-nodes-of-type ( type -- node-ids )
|
: 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"
|
"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-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 )
|
: select-nodes-of-type-with-content ( type content -- node-ids )
|
||||||
! find nodes with the given content that are the subjects of arcs with:
|
! find nodes with the given content that are the subjects of arcs with:
|
||||||
! relation = has-type-relation
|
! relation = has-type-relation
|
||||||
! object = type
|
! 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"
|
"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-node-of-type-with-content ( type content -- node-id/f )
|
||||||
select-nodes-of-type-with-content 1result ;
|
select-nodes-of-type-with-content 1result ;
|
||||||
|
|
||||||
: ensure-node-of-type ( type content -- node-id )
|
: 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 )
|
: ensure-type ( type -- node-id )
|
||||||
dup "type" = [
|
dup "type" = [
|
||||||
|
|
Loading…
Reference in New Issue