1 ! Copyright (C) 2008 Alex Chapman
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays combinators combinators.cleave combinators.lib
4 continuations db db.tuples db.types db.sqlite kernel math
5 math.parser namespaces parser lexer sets sequences sequences.deep
6 sequences.lib strings words destructors ;
9 TUPLE: node id content ;
14 { "id" "id" +db-assigned-id+ +autoincrement+ }
15 { "content" "content" TEXT }
18 : delete-node ( node -- ) delete-tuples ;
19 : create-node ( content -- node ) f swap <node> dup insert-tuple ;
20 : load-node ( id -- node ) f <node> select-tuple ;
22 : node-content ( node -- content )
23 dup content>> [ ] [ select-tuple content>> ] ?if ;
25 : node= ( node node -- ? ) [ id>> ] same? ;
27 ! TODO: get rid of arc id and write our own sql
28 TUPLE: arc id subject object relation ;
30 : <arc> ( subject object relation -- arc )
31 arc new swap >>relation swap >>object swap >>subject ;
33 : <id-arc> ( id -- arc )
36 : delete-arc ( arc -- ) delete-tuples ;
38 : create-arc ( subject object relation -- )
39 [ id>> ] tri@ <arc> insert-tuple ;
41 : nodes>arc ( subject object relation -- arc )
42 [ [ id>> ] [ f ] if* ] tri@ <arc> ;
44 : select-arcs ( subject object relation -- arcs )
45 nodes>arc select-tuples ;
47 : has-arc? ( subject object relation -- ? )
48 select-arcs length 0 > ;
50 : select-arc-subjects ( subject object relation -- subjects )
51 select-arcs [ subject>> f <node> ] map ;
53 : select-arc-subject ( subject object relation -- subject )
54 select-arcs ?first [ subject>> f <node> ] [ f ] if* ;
56 : select-subjects ( object relation -- subjects )
57 f -rot select-arc-subjects ;
59 : select-subject ( object relation -- subject )
60 f -rot select-arc-subject ;
62 : select-arc-objects ( subject object relation -- objects )
63 select-arcs [ object>> f <node> ] map ;
65 : select-arc-object ( subject object relation -- object )
66 select-arcs ?first [ object>> f <node> ] [ f ] if* ;
68 : select-objects ( subject relation -- objects )
69 f swap select-arc-objects ;
71 : select-object ( subject relation -- object )
72 f swap select-arc-object ;
74 : delete-arcs ( subject object relation -- )
75 select-arcs [ delete-arc ] each ;
79 { "id" "id" +db-assigned-id+ +autoincrement+ }
80 { "relation" "relation" INTEGER +not-null+ }
81 { "subject" "subject" INTEGER +not-null+ }
82 { "object" "object" INTEGER +not-null+ }
85 : create-bootstrap-nodes ( -- )
86 "semantic-db" create-node drop
87 "has-context" create-node drop ;
89 : semantic-db-context T{ node f 1 "semantic-db" } ;
90 : has-context-relation T{ node f 2 "has-context" } ;
92 : create-bootstrap-arcs ( -- )
93 has-context-relation semantic-db-context has-context-relation create-arc ;
95 : init-semantic-db ( -- )
96 node create-table arc create-table
97 create-bootstrap-nodes create-bootstrap-arcs ;
100 : results ( bindings sql -- array )
101 f f <simple-statement> [ do-bound-query ] with-disposal ;
103 : node-result ( result -- node )
104 dup first string>number swap second <node> ;
106 : ?1node-result ( results -- node )
107 ?first [ node-result ] [ f ] if* ;
109 : node-results ( results -- nodes )
110 [ node-result ] map ;
112 : param ( value key type -- param )
113 swapd <sqlite-low-level-binding> ;
115 : all-node-ids ( -- seq )
116 f "select n.id from node n" results [ first string>number ] map ;
118 : subjects-with-cor ( content object relation -- sql-results )
121 ":relation" INTEGER param ,
122 ":object" INTEGER param ,
123 ":content" TEXT param ,
125 "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 ;
127 : objects-with-csr ( content subject relation -- sql-results )
130 ":relation" INTEGER param ,
131 ":subject" INTEGER param ,
132 ":content" TEXT param ,
134 "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 ;
136 : (with-relation) ( content relation -- bindings sql )
137 id>> [ ":relation" INTEGER param , ":content" TEXT param , ] { } make
138 "select distinct n.id, n.content from node n, arc a where n.content = :content and a.relation = :relation" ;
140 : subjects-with-relation ( content relation -- sql-results )
141 (with-relation) " and a.object = n.id" append results ;
143 : objects-with-relation ( content relation -- sql-results )
144 (with-relation) " and a.subject = n.id" append results ;
146 : (ultimate) ( relation b a -- sql-results )
148 "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)" %
149 ] "" make [ id>> ":relation" INTEGER param 1array ] dip results ;
151 : ultimate-objects ( relation -- sql-results )
152 "subject" "object" (ultimate) ;
154 : ultimate-subjects ( relation -- sql-results )
155 "object" "subject" (ultimate) ;
158 ! - a node n is a context iff there exists a relation r such that r has context n
159 : create-context ( context-name -- context ) create-node ;
161 : get-context ( context-name -- context/f )
162 has-context-relation subjects-with-relation ?1node-result ;
164 : ensure-context ( context-name -- context )
172 ! - have a context in context 'semantic-db'
174 : create-relation ( relation-name context -- relation )
175 [ create-node dup ] dip has-context-relation create-arc ;
177 : get-relation ( relation-name context -- relation/f )
178 has-context-relation subjects-with-cor ?1node-result ;
180 : ensure-relation ( relation-name context -- relation )
187 TUPLE: relation-definition relate id-word unrelate related? subjects objects ;
188 C: <relation-definition> relation-definition
192 : default-word-name ( relate-word-name word-type -- name>> )
195 { "id-word" [ "-relation" append ] }
196 { "unrelate" [ "!" swap append ] }
197 { "related?" [ "?" append ] }
198 { "subjects" [ "-subjects" append ] }
199 { "objects" [ "-objects" append ] }
202 : choose-word-name ( relation-definition given-word-name word-type -- name>> )
206 nip [ relate>> ] dip default-word-name
209 : (define-relation-word) ( id-word name>> definition -- id-word )
210 >r create-word-in over [ execute ] curry r> compose define ;
212 : define-relation-word ( relation-definition id-word given-word-name word-type definition -- relation-definition id-word )
214 pick swap r> choose-word-name r> (define-relation-word)
219 : define-relation-words ( relation-definition id-word -- )
220 over relate>> "relate" [ create-arc ] define-relation-word
221 over unrelate>> "unrelate" [ delete-arcs ] define-relation-word
222 over related?>> "related?" [ has-arc? ] define-relation-word
223 over subjects>> "subjects" [ select-subjects ] define-relation-word
224 over objects>> "objects" [ select-objects ] define-relation-word
227 : define-id-word ( relation-definition id-word -- )
228 [ relate>> ] dip tuck vocabulary>>
229 [ ensure-context ensure-relation ] 2curry define ;
231 : create-id-word ( relation-definition -- id-word )
232 dup id-word>> "id-word" choose-word-name create-word-in ;
236 : define-relation ( relation-definition -- )
237 dup create-id-word 2dup define-id-word define-relation-words ;
240 scan t t t t t <relation-definition> define-relation ; parsing
243 TUPLE: node-tree node children ;
244 C: <node-tree> node-tree
246 : children ( node has-parent-relation -- children ) select-subjects ;
247 : parents ( node has-parent-relation -- parents ) select-objects ;
249 : get-node-tree ( node child-selector -- node-tree )
250 2dup call >r [ get-node-tree ] curry r> swap map <node-tree> ;
252 ! : get-node-tree ( node has-parent-relation -- node-tree )
253 ! 2dup children >r [ get-node-tree ] curry r> swap map <node-tree> ;
254 : get-node-tree-s ( node has-parent-relation -- tree )
255 [ select-subjects ] curry get-node-tree ;
257 : get-node-tree-o ( node has-child-relation -- tree )
258 [ select-objects ] curry get-node-tree ;
260 : (get-node-chain) ( node next-selector seq -- seq )
262 suffix! >r [ call ] keep r> (get-node-chain)
267 : get-node-chain ( node next-selector -- seq )
268 V{ } clone (get-node-chain) ;
270 : get-node-chain-o ( node relation -- seq )
271 [ select-object ] curry get-node-chain ;
273 : get-node-chain-s ( node relation -- seq )
274 [ select-subject ] curry get-node-chain ;
276 : (get-root-nodes) ( node has-parent-relation -- root-nodes/node )
277 2dup parents dup empty? [
280 >r nip [ (get-root-nodes) ] curry r> swap map
283 : get-root-nodes ( node has-parent-relation -- root-nodes )
284 (get-root-nodes) flatten prune ;