! 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 sequences ;
+USING: accessors arrays combinators combinators.cleave combinators.lib
+continuations db db.tuples db.types db.sqlite hashtables kernel math
+math.parser namespaces parser sequences sequences.deep
+sequences.lib strings words ;
IN: semantic-db
TUPLE: node id content ;
-: <node> ( content -- node )
- node new swap >>content ;
-
-: <id-node> ( id -- node )
- node new swap >>id ;
+C: <node> node
node "node"
{
{ "content" "content" TEXT }
} define-persistent
-: create-node-table ( -- )
- node create-table ;
-
-: delete-node ( node-id -- )
- <id-node> delete-tuple ;
+: delete-node ( node -- ) delete-tuple ;
+: create-node ( content -- node ) f swap <node> dup insert-tuple ;
+: load-node ( id -- node ) f <node> select-tuple ;
-: create-node* ( str -- node-id )
- <node> dup insert-tuple id>> ;
+: node-content ( node -- content )
+ dup content>> [ nip ] [ select-tuple content>> ] if* ;
-: create-node ( str -- )
- create-node* drop ;
+: node= ( node node -- ? ) [ id>> ] bi@ = ;
-: node-content ( id -- str )
- f <node> swap >>id select-tuple content>> ;
+! TODO: get rid of arc id and write our own sql
+TUPLE: arc id subject object relation ;
-TUPLE: arc id relation subject object ;
-
-: <arc> ( relation subject object -- arc )
- arc new swap >>object swap >>subject swap >>relation ;
+: <arc> ( subject object relation -- arc )
+ arc construct-empty swap >>relation swap >>object swap >>subject ;
: <id-arc> ( id -- arc )
arc new swap >>id ;
-: insert-arc ( arc -- )
- f <node> dup insert-tuple id>> >>id insert-tuple ;
+: delete-arc ( arc -- ) delete-tuple ;
+
+: create-arc ( subject object relation -- )
+ [ id>> ] 3apply <arc> insert-tuple ;
+
+: nodes>arc ( subject object relation -- arc )
+ [ [ id>> ] [ f ] if* ] 3apply <arc> ;
+
+: select-arcs ( subject object relation -- arcs )
+ nodes>arc select-tuples ;
+
+: has-arc? ( subject object relation -- ? )
+ select-arcs length 0 > ;
-: delete-arc ( arc-id -- )
- dup delete-node <id-arc> delete-tuple ;
+: select-arc-subjects ( subject object relation -- subjects )
+ select-arcs [ subject>> f <node> ] map ;
-: create-arc* ( relation subject object -- arc-id )
- <arc> dup insert-arc id>> ;
+: select-arc-subject ( subject object relation -- subject )
+ select-arcs ?first [ subject>> f <node> ] [ f ] if* ;
-: create-arc ( relation subject object -- )
- create-arc* drop ;
+: select-subjects ( object relation -- subjects )
+ f -rot select-arc-subjects ;
+
+: select-subject ( object relation -- subject )
+ f -rot select-arc-subject ;
+
+: select-arc-objects ( subject object relation -- objects )
+ select-arcs [ object>> f <node> ] map ;
+
+: select-arc-object ( subject object relation -- object )
+ select-arcs ?first [ object>> f <node> ] [ f ] if* ;
+
+: select-objects ( subject relation -- objects )
+ f swap select-arc-objects ;
+
+: select-object ( subject relation -- object )
+ f swap select-arc-object ;
+
+: delete-arcs ( subject object relation -- )
+ select-arcs [ delete-arc ] each ;
arc "arc"
{
- { "id" "id" INTEGER +assigned-id+ } ! foreign key to node table?
+ { "id" "id" +native-id+ +autoincrement+ }
{ "relation" "relation" INTEGER +not-null+ }
{ "subject" "subject" INTEGER +not-null+ }
{ "object" "object" INTEGER +not-null+ }
} define-persistent
-: 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 ;
+: semantic-db-context T{ node f 1 "semantic-db" } ;
+: has-context-relation T{ node f 2 "has-context" } ;
: 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 ;
: init-semantic-db ( -- )
- create-node-table create-arc-table create-bootstrap-nodes create-bootstrap-arcs ;
+ node create-table arc create-table
+ create-bootstrap-nodes create-bootstrap-arcs ;
+
- : param ( value key type -- param ) swapd 3array ;
-
+! db utilities
+: results ( bindings sql -- array )
+ f f <simple-statement> [ do-bound-query ] with-disposal ;
+
+: node-result ( result -- node )
+ dup first string>number swap second <node> ;
+
+: ?1node-result ( results -- node )
+ ?first [ node-result ] [ f ] if* ;
+
+: node-results ( results -- nodes )
+ [ node-result ] map ;
-: single-int-results ( bindings sql -- array )
- f f <simple-statement> [ do-bound-query ] with-disposal
- [ first string>number ] map ;
+ : param ( value key type -- param )
+ swapd <sqlite-low-level-binding> ;
+
+: subjects-with-cor ( content object relation -- sql-results )
+ [ id>> ] bi@
+ [
+ ":relation" INTEGER param ,
+ ":object" INTEGER param ,
+ ":content" TEXT param ,
+ ] { } make
+ "select n.id, n.content from node n, arc a where n.content = :content and n.id = a.subject and a.relation = :relation and a.object = :object" results ;
+
+: objects-with-csr ( content subject relation -- sql-results )
+ [ id>> ] bi@
+ [
+ ":relation" INTEGER param ,
+ ":subject" INTEGER param ,
+ ":content" TEXT param ,
+ ] { } make
+ "select n.id, n.content from node n, arc a where n.content = :content and n.id = a.object and a.relation = :relation and a.subject = :subject" results ;
+
+: (with-relation) ( content relation -- bindings sql )
+ id>> [ ":relation" INTEGER param , ":content" TEXT param , ] { } make
+ "select distinct n.id, n.content from node n, arc a where n.content = :content and a.relation = :relation" ;
+
+: subjects-with-relation ( content relation -- sql-results )
+ (with-relation) " and a.object = n.id" append results ;
+
+: objects-with-relation ( content relation -- sql-results )
+ (with-relation) " and a.subject = n.id" append results ;
+
+: (ultimate) ( relation b a -- sql-results )
+ [
+ "select distinct n.id, n.content from node n, arc a where a.relation = :relation and n.id = a." % % " and n.id not in (select b." % % " from arc b where b.relation = :relation)" %
+ ] "" make [ id>> ":relation" INTEGER param 1array ] dip results ;
+
+: ultimate-objects ( relation -- sql-results )
+ "subject" "object" (ultimate) ;
+
+: ultimate-subjects ( relation -- sql-results )
+ "object" "subject" (ultimate) ;
+
+! contexts:
+! - a node n is a context iff there exists a relation r such that r has context n
+: create-context ( context-name -- context ) create-node ;
+
+: get-context ( context-name -- context/f )
+ has-context-relation subjects-with-relation ?1node-result ;
+
+: ensure-context ( context-name -- context )
+ dup get-context [
+ nip
+ ] [
+ create-context
+ ] if* ;
+
+! relations:
+! - have a context in context 'semantic-db'
+
+: create-relation ( relation-name context -- relation )
+ [ create-node dup ] dip has-context-relation create-arc ;
+
+: get-relation ( relation-name context -- relation/f )
+ has-context-relation subjects-with-cor ?1node-result ;
+
+: ensure-relation ( relation-name context -- relation )
+ 2dup get-relation [
+ 2nip
+ ] [
+ create-relation
+ ] if* ;
+
+TUPLE: relation-definition relate id-word unrelate related? subjects objects ;
+C: <relation-definition> relation-definition
+
+<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
+ [ ensure-context ensure-relation ] 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:
+ scan t t t t t <relation-definition> define-relation ; parsing
+
+! hierarchy
+TUPLE: node-tree node children ;
+C: <node-tree> node-tree
+
+: children ( node has-parent-relation -- children ) select-subjects ;
+: parents ( node has-parent-relation -- parents ) select-objects ;
+
+: get-node-tree ( node child-selector -- node-tree )
+ 2dup call >r [ get-node-tree ] curry r> swap map <node-tree> ;
+
+! : get-node-tree ( node has-parent-relation -- node-tree )
+! 2dup children >r [ get-node-tree ] curry r> swap map <node-tree> ;
+: get-node-tree-s ( node has-parent-relation -- tree )
+ [ select-subjects ] curry get-node-tree ;
+
+: get-node-tree-o ( node has-child-relation -- tree )
+ [ select-objects ] curry get-node-tree ;
+
+: (get-node-chain) ( node next-selector seq -- seq )
+ pick [
+ over push >r [ call ] keep r> (get-node-chain)
+ ] [
+ 2nip
+ ] if* ;
+
+: get-node-chain ( node next-selector -- seq )
+ V{ } clone (get-node-chain) ;
+
+: get-node-chain-o ( node relation -- seq )
+ [ select-object ] curry get-node-chain ;
+
+: get-node-chain-s ( node relation -- seq )
+ [ select-subject ] curry get-node-chain ;
+
+: (get-root-nodes) ( node has-parent-relation -- root-nodes/node )
+ 2dup parents dup empty? [
+ 2drop
+ ] [
+ >r nip [ (get-root-nodes) ] curry r> swap map
+ ] if ;
-: 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* ;
+: get-root-nodes ( node has-parent-relation -- root-nodes )
+ (get-root-nodes) flatten prune ;
projects / factor.git / commitdiff