From 6bb2a46acb5cc4c9c3d641b761a47111b613765c Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Thu, 6 Mar 2008 23:54:16 +1100 Subject: [PATCH] semantic-db: I like the new stuff better than the old stuff --- extra/semantic-db/context/context.factor | 21 +++--- extra/semantic-db/hierarchy/hierarchy.factor | 52 +++++++------- extra/semantic-db/relations/relations.factor | 25 ++++--- extra/semantic-db/semantic-db-tests.factor | 68 ++++++++++++++----- extra/semantic-db/semantic-db.factor | 71 +++++++++----------- extra/semantic-db/type/type.factor | 6 +- 6 files changed, 136 insertions(+), 107 deletions(-) diff --git a/extra/semantic-db/context/context.factor b/extra/semantic-db/context/context.factor index 94ee000bcc..777c481ebb 100644 --- a/extra/semantic-db/context/context.factor +++ b/extra/semantic-db/context/context.factor @@ -1,19 +1,16 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: kernel semantic-db semantic-db.type ; +USING: kernel namespaces semantic-db ; IN: semantic-db.context -! contexts: -! - have type 'context' in context 'semantic-db' +: create-context* ( context-name -- context-id ) create-node* ; +: create-context ( context-name -- ) create-context* drop ; -: current-context ( -- context-id ) - \ current-context get ; +: context ( -- context-id ) + \ context get ; -: set-current-context ( context-id -- ) - \ current-context set ; +: set-context ( context-id -- ) + \ 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 ; +: with-context ( context-id quot -- ) + >r \ context r> with-variable ; diff --git a/extra/semantic-db/hierarchy/hierarchy.factor b/extra/semantic-db/hierarchy/hierarchy.factor index b764b23a7c..ef7670d15c 100644 --- a/extra/semantic-db/hierarchy/hierarchy.factor +++ b/extra/semantic-db/hierarchy/hierarchy.factor @@ -1,38 +1,44 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel new-slots semantic-db semantic-db.relations sequences ; +USING: accessors db.tuples kernel new-slots semantic-db semantic-db.relations sequences sequences.deep ; IN: semantic-db.hierarchy TUPLE: tree id children ; C: tree -! TODO: don't use context here. Hierarchies should be created within -! arbitrary contexts. -: hierarchy-context ( -- context-id ) - "hierarchy" context-id ; - : has-parent-relation ( -- relation-id ) - hierarchy-context "has parent" relation-id ; + "has parent" relation-id ; -: parent-of ( parent child -- arc-id ) - has-parent-relation spin create-arc ; +: parent-child* ( parent child -- arc-id ) + has-parent-relation spin create-arc* ; -: select-parents ( child -- parents ) +: parent-child ( parent child -- ) + parent-child* drop ; +: un-parent-child ( parent child -- ) + has-parent-relation -rot select-tuples [ id>> delete-arc ] each ; -: ensure-parent ( child parent -- ) - ! TODO - ; +: child-arcs ( node-id -- child-arcs ) + has-parent-relation f rot select-tuples ; -: find-children ( node-id -- children ) - ! find arcs with: - ! 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 ; +: children ( node-id -- children ) + child-arcs [ subject>> ] map ; + +: parent-arcs ( node-id -- parent-arcs ) + has-parent-relation swap f select-tuples ; + +: parents ( node-id -- parents ) + parent-arcs [ object>> ] map ; : get-node-hierarchy ( node-id -- tree ) - dup find-children ; + dup children [ get-node-hierarchy ] map ; + +: (get-root-nodes) ( node-id -- root-nodes/node-id ) + dup parents dup empty? [ + drop + ] [ + nip [ (get-root-nodes) ] map + ] if ; + +: get-root-nodes ( node-id -- root-nodes ) + (get-root-nodes) flatten ; diff --git a/extra/semantic-db/relations/relations.factor b/extra/semantic-db/relations/relations.factor index 65f246b80f..17c335c4ae 100644 --- a/extra/semantic-db/relations/relations.factor +++ b/extra/semantic-db/relations/relations.factor @@ -1,27 +1,26 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: kernel semantic-db semantic-db.context semantic-db.type ; +USING: db.types kernel namespaces semantic-db semantic-db.context +sequences.lib ; 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 ; +: create-relation* ( context-id relation-name -- relation-id ) + create-node* tuck has-context-relation spin create-arc ; -: select-relation ( context-id relation-name -- relation-id/f ) +: create-relation ( context-id relation-name -- ) + create-relation* drop ; + +: get-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 ; + "select n.id from node n, arc a where n.content = :name and n.id = a.subject and a.relation = :has_context and a.object = :context" + single-int-results ?first ; -: relation-id ( context-id relation-name -- relation-id ) - [ select-relation ] [ create-relation ] ensure2 ; - ! 2dup select-relation [ 2nip ] [ create-relation ] if* ; +: relation-id ( relation-name -- relation-id ) + context swap [ get-relation ] [ create-relation* ] ensure2 ; diff --git a/extra/semantic-db/semantic-db-tests.factor b/extra/semantic-db/semantic-db-tests.factor index 3aa9f2c2c7..4f67895a6f 100644 --- a/extra/semantic-db/semantic-db-tests.factor +++ b/extra/semantic-db/semantic-db-tests.factor @@ -1,26 +1,58 @@ -USING: accessors arrays db db.sqlite db.tuples kernel math semantic-db semantic-db.type sequences tools.test tools.walker ; -IN: temporary +USING: accessors arrays db db.sqlite db.tuples kernel math namespaces +semantic-db semantic-db.context semantic-db.hierarchy semantic-db.relations +sequences tools.test tools.walker ; +IN: vocab.tests [ create-node-table create-arc-table - [ 1 ] [ "first node" create-node ] unit-test - [ 2 ] [ "second node" create-node ] unit-test - [ 3 ] [ "third node" create-node ] unit-test - [ 4 ] [ f create-node ] unit-test - [ 5 ] [ 1 2 3 create-arc ] unit-test + [ 1 ] [ "first node" create-node* ] unit-test + [ 2 ] [ "second node" create-node* ] unit-test + [ 3 ] [ "third node" create-node* ] unit-test + [ 4 ] [ f create-node* ] unit-test + [ 5 ] [ 1 2 3 create-arc* ] unit-test ] with-tmp-sqlite [ init-semantic-db - 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 + "test content" create-context* [ + [ 4 ] [ context ] unit-test + [ 5 ] [ context "is test content" create-relation* ] unit-test + [ 5 ] [ context "is test content" get-relation ] unit-test + [ 5 ] [ "is test content" relation-id ] unit-test + [ 7 ] [ "has parent" relation-id ] unit-test + [ 7 ] [ "has parent" relation-id ] unit-test + [ "has parent" ] [ "has parent" relation-id node-content ] unit-test + [ "test content" ] [ context node-content ] unit-test + ] with-context + ! 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 + +! test hierarchy +[ + init-semantic-db + "family tree" create-context* [ + "adam" create-node* "adam" set + "eve" create-node* "eve" set + "bob" create-node* "bob" set + "fran" create-node* "fran" set + "charlie" create-node* "charlie" set + "gertrude" create-node* "gertrude" set + [ t ] [ "adam" get "bob" get parent-child* integer? ] unit-test + { { "eve" "bob" } { "eve" "fran" } { "bob" "gertrude" } { "fran" "charlie" } } [ first2 [ get ] 2apply parent-child ] each + [ { "bob" "fran" } ] [ "eve" get children [ node-content ] map ] unit-test + [ { "adam" "eve" } ] [ "bob" get parents [ node-content ] map ] unit-test + [ "fran" { "charlie" } ] [ "fran" get get-node-hierarchy dup tree-id node-content swap tree-children [ tree-id node-content ] map ] unit-test + [ { "adam" "eve" } ] [ "charlie" get get-root-nodes ] unit-test + [ { } ] [ "fran" get "charlie" get tuck un-parent-child parents ] unit-test + ] with-context ] with-tmp-sqlite diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor index 724eb3a58d..a48048f152 100644 --- a/extra/semantic-db/semantic-db.factor +++ b/extra/semantic-db/semantic-db.factor @@ -7,6 +7,9 @@ TUPLE: node id content ; : ( content -- node ) node construct-empty swap >>content ; +: ( id -- node ) + node construct-empty swap >>id ; + node "node" { { "id" "id" +native-id+ +autoincrement+ } @@ -16,14 +19,38 @@ node "node" : create-node-table ( -- ) node create-table ; -: create-node ( content -- id ) +: delete-node ( node-id -- ) + delete-tuple ; + +: create-node* ( str -- node-id ) dup insert-tuple id>> ; +: create-node ( str -- ) + create-node* drop ; + +: node-content ( id -- str ) + f swap >>id select-tuple content>> ; + TUPLE: arc id relation subject object ; : ( relation subject object -- arc ) arc construct-empty swap >>object swap >>subject swap >>relation ; +: ( id -- arc ) + arc construct-empty swap >>id ; + +: insert-arc ( arc -- ) + f dup insert-tuple id>> >>id insert-tuple ; + +: delete-arc ( arc-id -- ) + dup delete-node delete-tuple ; + +: create-arc* ( relation subject object -- arc-id ) + dup insert-arc id>> ; + +: create-arc ( relation subject object -- ) + create-arc* drop ; + arc "arc" { { "id" "id" INTEGER +assigned-id+ } ! foreign key to node table? @@ -35,47 +62,15 @@ arc "arc" : create-arc-table ( -- ) arc create-table ; -: insert-arc ( arc -- ) - f dup insert-tuple id>> >>id insert-tuple ; - -: delete-arc ( arc -- ) - dup delete-tuple delegate delete-tuple ; - -: create-arc ( relation subject object -- id ) - dup insert-arc id>> ; - : create-bootstrap-nodes ( -- ) - { "context" "type" "relation" "has type" "semantic-db" "has context" } - [ create-node drop ] each ; + "semantic-db" create-node + "has context" create-node ; -! TODO: maybe put these in a 'special nodes' table -: context-type 1 ; inline -: type-type 2 ; inline -: relation-type 3 ; inline -: has-type-relation 4 ; inline -: 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 ; +: semantic-db-context 1 ; +: has-context-relation 2 ; : create-bootstrap-arcs ( -- ) - ! give everything a type - 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 ; + has-context-relation has-context-relation semantic-db-context create-arc ; : init-semantic-db ( -- ) create-node-table create-arc-table create-bootstrap-nodes create-bootstrap-arcs ; diff --git a/extra/semantic-db/type/type.factor b/extra/semantic-db/type/type.factor index f2691103e7..7eec2fe179 100644 --- a/extra/semantic-db/type/type.factor +++ b/extra/semantic-db/type/type.factor @@ -8,10 +8,10 @@ IN: semantic-db.type ! - have a context in context 'semantic-db' : assign-type ( type nid -- arc-id ) - has-type-relation spin create-arc ; + has-type-relation spin arc-id ; : create-node-of-type ( type content -- node-id ) - create-node [ assign-type drop ] keep ; + node-id [ assign-type drop ] keep ; : select-nodes-of-type ( type -- node-ids ) ":type" INTEGER param @@ -33,7 +33,7 @@ IN: semantic-db.type single-int-results ; : select-node-of-type-with-content ( type content -- node-id/f ) - select-nodes-of-type-with-content 1result ; + select-nodes-of-type-with-content ?first ; : ensure-node-of-type ( type content -- node-id ) [ select-node-of-type-with-content ] [ create-node-of-type ] ensure2 ;