From 43aba96e8c858617638edf8e5ff3796f24f2b4f8 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Tue, 25 Mar 2008 17:38:14 +1100 Subject: [PATCH] semantic-db: new RELATION: syntax --- extra/semantic-db/semantic-db-tests.factor | 81 +++++++++--------- extra/semantic-db/semantic-db.factor | 96 ++++++++++++++-------- 2 files changed, 102 insertions(+), 75 deletions(-) diff --git a/extra/semantic-db/semantic-db-tests.factor b/extra/semantic-db/semantic-db-tests.factor index 0dccab330b..7fa0ff2176 100644 --- a/extra/semantic-db/semantic-db-tests.factor +++ b/extra/semantic-db/semantic-db-tests.factor @@ -5,7 +5,6 @@ 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 ; @@ -22,43 +21,43 @@ test-db [ [ 5 ] [ 1 2 3 create-arc ] unit-test ] with-db delete-db -test-db [ - init-semantic-db - "test content" create-context context set - [ 4 ] [ context get ] 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 -] with-db delete-db - -! test hierarchy -test-db [ - init-semantic-db - "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 - -RELATION: test-relation - -test-db [ - init-semantic-db - [ 5 ] [ test-relation ] unit-test -] with-db delete-db - + test-db [ + init-semantic-db + "test content" create-context context set + [ 4 ] [ context get ] 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 + ] with-db delete-db + + ! "test1" f f f f f define-relation + ! "test2" t t t t t define-relation + RELATION: test + test-db [ + init-semantic-db + [ 5 ] [ test-relation ] unit-test + ] with-db delete-db + + ! test hierarchy + RELATION: has-parent + test-db [ + init-semantic-db + "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 ] [ "bob" get "adam" get has-parent integer? ] unit-test + { { "bob" "eve" } { "fran" "eve" } { "gertrude" "bob" } { "fran" "bob" } { "charlie" "fran" } } [ first2 [ get ] 2apply has-parent drop ] each + [ { "bob" "fran" } ] [ "eve" get has-parent-relation children [ node-content ] map ] unit-test + [ { "adam" "eve" } ] [ "bob" get has-parent-relation parents [ node-content ] map ] unit-test + [ "fran" { "charlie" } ] [ "fran" get has-parent-relation 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-root-nodes [ node-content ] map natural-sort >array ] unit-test + [ { } ] [ "charlie" get dup "fran" get !has-parent has-parent-relation 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 f73b76327b..d4e2c1ed1a 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 combinators.cleave continuations db db.tuples db.types db.sqlite hashtables kernel math math.parser namespaces new-slots parser sequences sequences.deep sequences.lib words ; +USING: accessors arrays combinators combinators.cleave continuations db db.tuples db.types db.sqlite hashtables kernel math math.parser namespaces new-slots parser sequences sequences.deep sequences.lib strings words ; IN: semantic-db TUPLE: node id content ; @@ -54,18 +54,18 @@ TUPLE: arc id subject object relation ; : select-arc-subjects ( subject object relation -- subject-ids ) select-arcs [ subject>> ] map ; +: select-subjects ( object relation -- subject-ids ) + f -rot select-arc-subjects ; + : select-arc-objects ( subject object relation -- object-ids ) select-arcs [ object>> ] map ; +: select-objects ( subject relation -- object-ids ) + f swap select-arc-objects ; + : delete-arcs ( subject object relation -- ) select-arcs [ id>> delete-arc ] each ; -: subject-relation ( subject relation -- subject object relation ) - f swap ; - -: object-relation ( object relation -- subject object relation ) - f -rot ; - arc "arc" { { "id" "id" INTEGER +assigned-id+ } ! foreign key to node table? @@ -139,28 +139,67 @@ arc "arc" : relation-id ( relation-name context-id -- relation-id ) [ get-relation ] [ create-relation ] ensure2 ; -! RELATION: is-fooey -! - define a word is-fooey in the current vocab (foo), that when called: -! - finds or creates a node called "is-fooey" with context "foo", and returns its id +TUPLE: relation-definition relate id-word unrelate related? subjects objects ; +C: relation-definition + +> ] dip default-word-name + ] if ; + +: (define-relation-word) ( id-word word-name definition -- id-word ) + >r create-in over [ execute ] curry r> compose define ; + +: define-relation-word ( relation-definition id-word given-word-name word-type definition -- relation-definition id-word ) + >r >r [ + pick swap r> choose-word-name r> (define-relation-word) + ] [ + r> r> 2drop + ] if* ; + +: define-relation-words ( relation-definition id-word -- ) + over relate>> "relate" [ create-arc ] define-relation-word + over unrelate>> "unrelate" [ delete-arcs ] define-relation-word + over related?>> "related?" [ has-arc? ] define-relation-word + over subjects>> "subjects" [ select-subjects ] define-relation-word + over objects>> "objects" [ select-objects ] define-relation-word + 2drop ; + +: define-id-word ( relation-definition id-word -- ) + [ relate>> ] dip tuck word-vocabulary + [ context-id relation-id ] 2curry define ; + +: create-id-word ( relation-definition -- id-word ) + dup id-word>> "id-word" choose-word-name create-in ; + +PRIVATE> + +: define-relation ( relation-definition -- ) + dup create-id-word 2dup define-id-word define-relation-words ; + : RELATION: - CREATE-WORD dup [ word-name ] [ word-vocabulary ] bi - [ context-id relation-id ] 2curry define ; parsing + scan t t t t t define-relation ; parsing ! 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 delete-arcs ; - -: children ( node-id has-parent-relation -- children ) - object-relation select-arc-subjects ; - -: parents ( node-id has-parent-relation -- parents ) - subject-relation select-arc-objects ; +: children ( node-id has-parent-relation -- children ) select-subjects ; +: parents ( node-id has-parent-relation -- parents ) select-objects ; : get-node-hierarchy ( node-id has-parent-relation -- tree ) 2dup children >r [ get-node-hierarchy ] curry r> swap map ; @@ -175,14 +214,3 @@ C: tree : get-root-nodes ( node-id has-parent-relation -- root-nodes ) (get-root-nodes) flatten prune ; -! sets -: in-set ( member set in-set-relation -- arc-id ) create-arc ; -: in-set? ( member set in-set-relation -- ? ) has-arc? ; -: set-members ( set in-set-relation -- members ) - object-relation select-arc-subjects ; - -! attributes -: has-attribute ( node value has-attribute-relation -- arc-id ) create-arc ; -: has-attribute? ( node value has-attribute-relation -- ? ) has-arc? ; -: nodes-with-attribute ( value has-attribute-relation -- node-ids ) - object-relation select-arc-subjects ;