semantic-db: new RELATION: syntax

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 ;
@@ -35,30 +34,30 @@ test-db [
      [ "test content" ] [ context get node-content ] unit-test
  ] with-db delete-db
  
-! test hierarchy
+ ! "test1" f f f f f <relation-definition> define-relation
+ ! "test2" t t t t t <relation-definition> 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
-    "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
+      [ t ] [ "bob" get "adam" get has-parent 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" "eve" } { "fran" "eve" } { "gertrude" "bob" } { "fran" "bob" } { "charlie" "fran" } } [ first2 [ get ] 2apply has-parent drop ] each
-    [ { "bob" "fran" } ] [ "eve" get has-parent-relation get children [ node-content ] map ] unit-test
+     [ { "bob" "fran" } ] [ "eve" get has-parent-relation children [ node-content ] map ] unit-test
-    [ { "adam" "eve" } ] [ "bob" get has-parent-relation get parents [ 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 get-node-hierarchy dup tree-id node-content swap tree-children [ tree-id 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 get-root-nodes [ node-content ] map natural-sort >array ] unit-test
+     [ { "adam" "eve" } ] [ "charlie" get has-parent-relation 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
+     [ { } ] [ "charlie" get dup "fran" get !has-parent has-parent-relation 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
  

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
+TUPLE: relation-definition relate id-word unrelate related? subjects objects ;
-!  - define a word is-fooey in the current vocab (foo), that when called:
+C: <relation-definition> relation-definition
-!    - finds or creates a node called "is-fooey" with context "foo", and returns its id
+
+<PRIVATE
+
+: default-word-name ( relate-word-name word-type -- word-name )
+    {
+        { "relate" [ ] }
+        { "id-word" [ "-relation" append ] }
+        { "unrelate" [ "!" swap append ] }
+        { "related?" [ "?" append ] }
+        { "subjects" [ "-subjects" append ] }
+        { "objects" [ "-objects" append ] }
+    } case ;
+
+: choose-word-name ( relation-definition given-word-name word-type -- word-name )
+    over string? [
+        drop nip
+    ] [
+        nip [ relate>> ] 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
+    scan t t t t t <relation-definition> define-relation ; parsing
-    [ context-id relation-id ] 2curry define ; parsing
 
 ! hierarchy
 TUPLE: tree id children ;
 C: <tree> tree
 
-: parent-child ( parent child has-parent-relation -- arc-id )
+: children ( node-id has-parent-relation -- children ) select-subjects ;
-    swapd create-arc ;
+: parents ( node-id has-parent-relation -- parents ) select-objects ;
-
-: 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 ;
 
 : get-node-hierarchy ( node-id has-parent-relation -- tree )
     2dup children >r [ get-node-hierarchy ] curry r> swap map <tree> ;
@@ -175,14 +214,3 @@ C: <tree> 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 ;