From c90c0025c7544e54bb696e686a7271f55d55f2f7 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Wed, 19 Mar 2008 21:22:15 +1100 Subject: [PATCH] semantic-db: move everything into one vocab --- extra/semantic-db/context/context.factor | 10 --- extra/semantic-db/hierarchy/hierarchy.factor | 44 --------- .../semantic-db/membership/membership.factor | 6 -- extra/semantic-db/relations/relations.factor | 26 ------ extra/semantic-db/semantic-db-tests.factor | 66 +++++++------- extra/semantic-db/semantic-db.factor | 90 +++++++++++++++---- 6 files changed, 107 insertions(+), 135 deletions(-) delete mode 100644 extra/semantic-db/context/context.factor delete mode 100644 extra/semantic-db/hierarchy/hierarchy.factor delete mode 100644 extra/semantic-db/membership/membership.factor delete mode 100644 extra/semantic-db/relations/relations.factor diff --git a/extra/semantic-db/context/context.factor b/extra/semantic-db/context/context.factor deleted file mode 100644 index 9d2e175b5e..0000000000 --- a/extra/semantic-db/context/context.factor +++ /dev/null @@ -1,10 +0,0 @@ -! Copyright (C) 2008 Alex Chapman -! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces semantic-db ; -IN: semantic-db.context - -: create-context* ( context-name -- context-id ) create-node* ; -: create-context ( context-name -- ) create-context* drop ; - -SYMBOL: context - diff --git a/extra/semantic-db/hierarchy/hierarchy.factor b/extra/semantic-db/hierarchy/hierarchy.factor deleted file mode 100644 index f180ddb5df..0000000000 --- a/extra/semantic-db/hierarchy/hierarchy.factor +++ /dev/null @@ -1,44 +0,0 @@ -! Copyright (C) 2008 Alex Chapman -! See http://factorcode.org/license.txt for BSD license. -USING: accessors db.tuples hashtables kernel namespaces new-slots -semantic-db semantic-db.relations sequences sequences.deep ; -IN: semantic-db.hierarchy - -TUPLE: tree id children ; -C: tree - -SYMBOL: has-parent-relation - -: parent-child* ( parent child -- arc-id ) - has-parent-relation get spin create-arc* ; - -: parent-child ( parent child -- ) - parent-child* drop ; - -: un-parent-child ( parent child -- ) - has-parent-relation get spin select-tuples [ id>> delete-arc ] each ; - -: child-arcs ( node-id -- child-arcs ) - has-parent-relation get f rot select-tuples ; - -: children ( node-id -- children ) - child-arcs [ subject>> ] map ; - -: parent-arcs ( node-id -- parent-arcs ) - has-parent-relation get swap f select-tuples ; - -: parents ( node-id -- parents ) - parent-arcs [ object>> ] map ; - -: get-node-hierarchy ( node-id -- tree ) - 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 prune ; diff --git a/extra/semantic-db/membership/membership.factor b/extra/semantic-db/membership/membership.factor deleted file mode 100644 index c386922979..0000000000 --- a/extra/semantic-db/membership/membership.factor +++ /dev/null @@ -1,6 +0,0 @@ -! Copyright (C) 2008 Alex Chapman -! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel new-slots semantic-db semantic-db.relations ; -IN: semantic-db.membership - - diff --git a/extra/semantic-db/relations/relations.factor b/extra/semantic-db/relations/relations.factor deleted file mode 100644 index 58003c9e9d..0000000000 --- a/extra/semantic-db/relations/relations.factor +++ /dev/null @@ -1,26 +0,0 @@ -! Copyright (C) 2008 Alex Chapman -! See http://factorcode.org/license.txt for BSD license. -USING: db.types kernel namespaces semantic-db semantic-db.context -sequences.lib ; -IN: semantic-db.relations - -! relations: -! - have a context in context 'semantic-db' - -: create-relation* ( context-id relation-name -- relation-id ) - create-node* tuck has-context-relation spin create-arc ; - -: create-relation ( context-id relation-name -- ) - create-relation* drop ; - -: get-relation ( context-id relation-name -- relation-id/f ) - [ - ":name" TEXT param , - ":context" INTEGER param , - has-context-relation ":has_context" INTEGER param , - ] { } make - "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 ( relation-name -- relation-id ) - context get 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 fad2ea6332..47363b8f5d 100644 --- a/extra/semantic-db/semantic-db-tests.factor +++ b/extra/semantic-db/semantic-db-tests.factor @@ -1,10 +1,12 @@ -USING: accessors arrays continuations db db.sqlite -db.tuples io.files kernel math namespaces semantic-db -semantic-db.context semantic-db.hierarchy -semantic-db.relations sequences sorting tools.test -tools.walker ; +USING: accessors arrays continuations db db.sqlite db.tuples io.files +kernel math namespaces semantic-db + +sequences sorting tools.test tools.walker ; IN: semantic-db.tests +SYMBOL: context +SYMBOL: has-parent-relation + : db-path "semantic-db-test.db" temp-file ; : test-db db-path sqlite-db ; : delete-db [ db-path delete-file ] ignore-errors ; @@ -13,25 +15,25 @@ delete-db test-db [ 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-db delete-db test-db [ init-semantic-db - "test content" create-context* context set + "test content" create-context context set [ 4 ] [ context get ] unit-test - [ 5 ] [ context get "is test content" create-relation* ] unit-test - [ 5 ] [ context get "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 + [ 5 ] [ "is test content" context get create-relation ] unit-test + [ 5 ] [ "is test content" context get get-relation ] unit-test + [ 5 ] [ "is test content" context get relation-id ] unit-test + [ 7 ] [ "has parent" context get relation-id ] unit-test + [ 7 ] [ "has parent" context get relation-id ] unit-test + [ "has parent" ] [ "has parent" context get relation-id node-content ] unit-test [ "test content" ] [ context get node-content ] unit-test ! type-type 1array [ "type" ensure-type ] unit-test ! [ { 1 2 3 } ] [ type-type select-nodes-of-type ] unit-test @@ -51,21 +53,21 @@ delete-db ! test hierarchy test-db [ init-semantic-db - "family tree" create-context* context set - "has parent" relation-id has-parent-relation set - "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" } { "bob" "fran" } { "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 [ node-content ] map natural-sort >array ] unit-test - [ { } ] [ "fran" get "charlie" get tuck un-parent-child parents [ node-content ] map ] unit-test + "family tree" create-context context set + "has parent" context get relation-id has-parent-relation set + "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 has-parent-relation get parent-child integer? ] unit-test + { { "eve" "bob" } { "eve" "fran" } { "bob" "gertrude" } { "bob" "fran" } { "fran" "charlie" } } [ first2 [ get ] 2apply has-parent-relation get parent-child drop ] each + [ { "bob" "fran" } ] [ "eve" get has-parent-relation get children [ node-content ] map ] unit-test + [ { "adam" "eve" } ] [ "bob" get has-parent-relation get parents [ node-content ] map ] unit-test + [ "fran" { "charlie" } ] [ "fran" get has-parent-relation get get-node-hierarchy dup tree-id node-content swap tree-children [ tree-id node-content ] map ] unit-test + [ { "adam" "eve" } ] [ "charlie" get has-parent-relation get get-root-nodes [ node-content ] map natural-sort >array ] unit-test + [ { } ] [ "fran" get "charlie" get tuck has-parent-relation get un-parent-child has-parent-relation get parents [ node-content ] map ] unit-test ] with-db delete-db diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor index e8075c016d..340514fd11 100644 --- a/extra/semantic-db/semantic-db.factor +++ b/extra/semantic-db/semantic-db.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays continuations db db.tuples db.types db.sqlite kernel math math.parser new-slots sequences ; +USING: accessors arrays continuations db db.tuples db.types db.sqlite hashtables kernel math math.parser namespaces new-slots sequences sequences.deep sequences.lib ; IN: semantic-db TUPLE: node id content ; @@ -22,19 +22,16 @@ node "node" : delete-node ( node-id -- ) delete-tuple ; -: create-node* ( str -- node-id ) +: 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 ; +TUPLE: arc id subject object relation ; -: ( relation subject object -- arc ) - arc construct-empty swap >>object swap >>subject swap >>relation ; +: ( subject object relation -- arc ) + arc construct-empty swap >>relation swap >>object swap >>subject ; : ( id -- arc ) arc construct-empty swap >>id ; @@ -45,12 +42,9 @@ TUPLE: arc id relation subject object ; : delete-arc ( arc-id -- ) dup delete-node delete-tuple ; -: create-arc* ( relation subject object -- arc-id ) +: create-arc ( subject object relation -- 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? @@ -59,18 +53,17 @@ arc "arc" { "object" "object" INTEGER +not-null+ } } define-persistent -: create-arc-table ( -- ) - arc create-table ; +: create-arc-table ( -- ) arc create-table ; : create-bootstrap-nodes ( -- ) - "semantic-db" create-node - "has context" create-node ; + "semantic-db" create-node drop + "has context" create-node drop ; : semantic-db-context 1 ; : has-context-relation 2 ; : create-bootstrap-arcs ( -- ) - has-context-relation has-context-relation semantic-db-context create-arc ; + has-context-relation semantic-db-context has-context-relation create-arc drop ; : init-semantic-db ( -- ) create-node-table create-arc-table create-bootstrap-nodes create-bootstrap-arcs ; @@ -87,3 +80,66 @@ arc "arc" #! quot2 ( x y -- z ) creates a new z if quot1 returns f >r >r 2dup r> call [ 2nip ] r> if* ; +: create-context ( context-name -- context-id ) create-node ; + +! relations: +! - have a context in context 'semantic-db' + +: create-relation ( relation-name context-id -- relation-id ) + [ create-node dup ] dip has-context-relation create-arc drop ; + +: get-relation ( relation-name context-id -- relation-id/f ) + [ + ":context" INTEGER param , + ":name" TEXT param , + has-context-relation ":has_context" INTEGER param , + ] { } make + "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 ( relation-name context-id -- relation-id ) + [ get-relation ] [ create-relation ] ensure2 ; + +! hierarchy +TUPLE: tree id children ; +C: tree + +: parent-child ( parent child has-parent-relation -- arc-id ) swapd create-arc ; + +: un-parent-child ( parent child has-parent-relation -- ) + swapd select-tuples [ id>> delete-arc ] each ; + +: child-arcs ( parent-id has-parent-relation -- child-arcs ) + f -rot select-tuples ; + +: children ( node-id has-parent-relation -- children ) + child-arcs [ subject>> ] map ; + +: parent-arcs ( node-id has-parent-relation -- parent-arcs ) + f swap select-tuples ; + +: parents ( node-id has-parent-relation -- parents ) + parent-arcs [ object>> ] map ; + +: get-node-hierarchy ( node-id has-parent-relation -- tree ) + 2dup children >r [ get-node-hierarchy ] curry r> swap map ; + +: (get-root-nodes) ( node-id has-parent-relation -- root-nodes/node-id ) + 2dup parents dup empty? [ + 2drop + ] [ + >r nip [ (get-root-nodes) ] curry r> swap map + ] if ; + +: get-root-nodes ( node-id has-parent-relation -- root-nodes ) + (get-root-nodes) flatten prune ; + +! sets + +: in-set* ( set member in-set-relation -- arc-id ) swapd create-arc ; + +: in-set? ( set member in-set-relation -- ? ) + swapd select-tuples length 0 > ; + +: set-members ( set in-set-relation -- members ) + f -rot select-tuples [ id>> ] map ;