From 4222b6299bb05e3010c96aeac0ab724f9c3dc0c4 Mon Sep 17 00:00:00 2001
From: Alex Chapman <chapman.alex@gmail.com>
Date: Thu, 6 Mar 2008 12:37:51 +1100
Subject: [PATCH] experimental semantic-db before a major change
---
extra/semantic-db/context/context.factor | 17 ++++--
extra/semantic-db/hierarchy/hierarchy.factor | 25 +++++---
extra/semantic-db/relations/relations.factor | 27 +++++++++
extra/semantic-db/semantic-db-tests.factor | 17 ++++--
extra/semantic-db/semantic-db.factor | 63 +++++++++++---------
extra/semantic-db/type/type.factor | 26 ++++----
6 files changed, 118 insertions(+), 57 deletions(-)
create mode 100644 extra/semantic-db/relations/relations.factor
diff --git a/extra/semantic-db/context/context.factor b/extra/semantic-db/context/context.factor
index e103fbc92e..94ee000bcc 100644
--- a/extra/semantic-db/context/context.factor
+++ b/extra/semantic-db/context/context.factor
@@ -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 ;
diff --git a/extra/semantic-db/hierarchy/hierarchy.factor b/extra/semantic-db/hierarchy/hierarchy.factor
index 4feb3d8d6d..b764b23a7c 100644
--- a/extra/semantic-db/hierarchy/hierarchy.factor
+++ b/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:
- ! 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> ;
diff --git a/extra/semantic-db/relations/relations.factor b/extra/semantic-db/relations/relations.factor
new file mode 100644
index 0000000000..65f246b80f
--- /dev/null
+++ b/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* ;
diff --git a/extra/semantic-db/semantic-db-tests.factor b/extra/semantic-db/semantic-db-tests.factor
index 1ac4a76d3a..3aa9f2c2c7 100644
--- a/extra/semantic-db/semantic-db-tests.factor
+++ b/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
- [ 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
diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor
index f6a6983ae4..724eb3a58d 100644
--- a/extra/semantic-db/semantic-db.factor
+++ b/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
- 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* ;
diff --git a/extra/semantic-db/type/type.factor b/extra/semantic-db/type/type.factor
index 32c93fdb80..f2691103e7 100644
--- a/extra/semantic-db/type/type.factor
+++ b/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
- 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" = [