unmaintained/semantic-db/semantic-db.factor

   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 ;
   7 IN: semantic-db
   8
   9 TUPLE: node id content ;
  10 C: <node> node
  11
  12 node "node"
  13 {
  14     { "id" "id" +db-assigned-id+ +autoincrement+ }
  15     { "content" "content" TEXT }
  16 } define-persistent
  17
  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 ;
  21
  22 : node-content ( node -- content )
  23     dup content>> [ ] [ select-tuple content>> ] ?if ;
  24
  25 : node= ( node node -- ? ) [ id>> ] same? ;
  26
  27 ! TODO: get rid of arc id and write our own sql
  28 TUPLE: arc id subject object relation ;
  29
  30 : <arc> ( subject object relation -- arc )
  31     arc new swap >>relation swap >>object swap >>subject ;
  32
  33 : <id-arc> ( id -- arc )
  34     arc new swap >>id ;
  35
  36 : delete-arc ( arc -- ) delete-tuples ;
  37
  38 : create-arc ( subject object relation -- )
  39     [ id>> ] tri@ <arc> insert-tuple ;
  40
  41 : nodes>arc ( subject object relation -- arc )
  42     [ [ id>> ] [ f ] if* ] tri@ <arc> ;
  43
  44 : select-arcs ( subject object relation -- arcs )
  45     nodes>arc select-tuples ;
  46
  47 : has-arc? ( subject object relation -- ? )
  48     select-arcs length 0 > ;
  49
  50 : select-arc-subjects ( subject object relation -- subjects )
  51     select-arcs [ subject>> f <node> ] map ;
  52
  53 : select-arc-subject ( subject object relation -- subject )
  54     select-arcs ?first [ subject>> f <node> ] [ f ] if* ;
  55
  56 : select-subjects ( object relation -- subjects )
  57     f -rot select-arc-subjects ;
  58
  59 : select-subject ( object relation -- subject )
  60     f -rot select-arc-subject ;
  61
  62 : select-arc-objects ( subject object relation -- objects )
  63     select-arcs [ object>> f <node> ] map ;
  64
  65 : select-arc-object ( subject object relation -- object )
  66     select-arcs ?first [ object>> f <node> ] [ f ] if* ;
  67
  68 : select-objects ( subject relation -- objects )
  69     f swap select-arc-objects ;
  70
  71 : select-object ( subject relation -- object )
  72     f swap select-arc-object ;
  73
  74 : delete-arcs ( subject object relation -- )
  75     select-arcs [ delete-arc ] each ;
  76
  77 arc "arc"
  78 {
  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+ }
  83 } define-persistent
  84
  85 : create-bootstrap-nodes ( -- )
  86     "semantic-db" create-node drop
  87     "has-context" create-node drop ;
  88
  89 : semantic-db-context  T{ node f 1 "semantic-db" } ;
  90 : has-context-relation T{ node f 2 "has-context" } ;
  91
  92 : create-bootstrap-arcs ( -- )
  93     has-context-relation semantic-db-context has-context-relation create-arc ;
  94
  95 : init-semantic-db ( -- )
  96     node create-table arc create-table
  97     create-bootstrap-nodes create-bootstrap-arcs ;
  98
  99 ! db utilities
 100 : results ( bindings sql -- array )
 101     f f <simple-statement> [ do-bound-query ] with-disposal ;
 102
 103 : node-result ( result -- node )
 104     dup first string>number swap second <node> ;
 105
 106 : ?1node-result ( results -- node )
 107     ?first [ node-result ] [ f ] if* ;
 108
 109 : node-results ( results -- nodes )
 110     [ node-result ] map ;
 111
 112 : param ( value key type -- param )
 113     swapd <sqlite-low-level-binding> ;
 114
 115 : all-node-ids ( -- seq )
 116     f "select n.id from node n" results [ first string>number ] map ;
 117
 118 : subjects-with-cor ( content object relation -- sql-results )
 119     [ id>> ] bi@
 120     [
 121         ":relation" INTEGER param ,
 122         ":object" INTEGER param ,
 123         ":content" TEXT param ,
 124     ] { } make
 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 ;
 126
 127 : objects-with-csr ( content subject relation -- sql-results )
 128     [ id>> ] bi@
 129     [
 130         ":relation" INTEGER param ,
 131         ":subject" INTEGER param ,
 132         ":content" TEXT param ,
 133     ] { } make
 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 ;
 135
 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" ;
 139
 140 : subjects-with-relation ( content relation -- sql-results )
 141     (with-relation) " and a.object = n.id" append results ;
 142
 143 : objects-with-relation ( content relation -- sql-results )
 144     (with-relation) " and a.subject = n.id" append results ;
 145
 146 : (ultimate) ( relation b a -- sql-results )
 147     [
 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 ;
 150
 151 : ultimate-objects ( relation -- sql-results )
 152     "subject" "object" (ultimate) ;
 153
 154 : ultimate-subjects ( relation -- sql-results )
 155     "object" "subject" (ultimate) ;
 156
 157 ! contexts:
 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 ;
 160
 161 : get-context ( context-name -- context/f )
 162     has-context-relation subjects-with-relation ?1node-result ;
 163
 164 : ensure-context ( context-name -- context )
 165     dup get-context [
 166         nip
 167     ] [
 168         create-context
 169     ] if* ;
 170
 171 ! relations:
 172 !  - have a context in context 'semantic-db'
 173
 174 : create-relation ( relation-name context -- relation )
 175     [ create-node dup ] dip has-context-relation create-arc ;
 176
 177 : get-relation ( relation-name context -- relation/f )
 178     has-context-relation subjects-with-cor ?1node-result ;
 179
 180 : ensure-relation ( relation-name context -- relation )
 181     2dup get-relation [
 182         2nip
 183     ] [
 184         create-relation
 185     ] if* ;
 186
 187 TUPLE: relation-definition relate id-word unrelate related? subjects objects ;
 188 C: <relation-definition> relation-definition
 189
 190 <PRIVATE
 191
 192 : default-word-name ( relate-word-name word-type -- name>> )
 193     {
 194         { "relate" [ ] }
 195         { "id-word" [ "-relation" append ] }
 196         { "unrelate" [ "!" swap append ] }
 197         { "related?" [ "?" append ] }
 198         { "subjects" [ "-subjects" append ] }
 199         { "objects" [ "-objects" append ] }
 200     } case ;
 201
 202 : choose-word-name ( relation-definition given-word-name word-type -- name>> )
 203     over string? [
 204         drop nip
 205     ] [
 206         nip [ relate>> ] dip default-word-name
 207     ] if ;
 208
 209 : (define-relation-word) ( id-word name>> definition -- id-word )
 210     >r create-word-in over [ execute ] curry r> compose define ;
 211
 212 : define-relation-word ( relation-definition id-word given-word-name word-type definition -- relation-definition id-word )
 213     >r >r [
 214         pick swap r> choose-word-name r> (define-relation-word)
 215     ] [
 216         r> r> 2drop
 217     ] if*  ;
 218
 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
 225     2drop ;
 226
 227 : define-id-word ( relation-definition id-word -- )
 228     [ relate>> ] dip tuck vocabulary>>
 229     [ ensure-context ensure-relation ] 2curry define ;
 230
 231 : create-id-word ( relation-definition -- id-word )
 232     dup id-word>> "id-word" choose-word-name create-word-in ;
 233
 234 PRIVATE>
 235
 236 : define-relation ( relation-definition -- )
 237     dup create-id-word 2dup define-id-word define-relation-words ;
 238
 239 : RELATION:
 240     scan t t t t t <relation-definition> define-relation ; parsing
 241
 242 ! hierarchy
 243 TUPLE: node-tree node children ;
 244 C: <node-tree> node-tree
 245
 246 : children ( node has-parent-relation -- children ) select-subjects ;
 247 : parents ( node has-parent-relation -- parents ) select-objects ;
 248
 249 : get-node-tree ( node child-selector -- node-tree )
 250     2dup call >r [ get-node-tree ] curry r> swap map <node-tree> ;
 251
 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 ;
 256
 257 : get-node-tree-o ( node has-child-relation -- tree )
 258     [ select-objects ] curry get-node-tree ;
 259
 260 : (get-node-chain) ( node next-selector seq -- seq )
 261     pick [
 262         suffix! >r [ call ] keep r> (get-node-chain)
 263     ] [
 264         2nip
 265     ] if* ;
 266
 267 : get-node-chain ( node next-selector -- seq )
 268     V{ } clone (get-node-chain) ;
 269
 270 : get-node-chain-o ( node relation -- seq )
 271     [ select-object ] curry get-node-chain ;
 272
 273 : get-node-chain-s ( node relation -- seq )
 274     [ select-subject ] curry get-node-chain ;
 275
 276 : (get-root-nodes) ( node has-parent-relation -- root-nodes/node )
 277     2dup parents dup empty? [
 278         2drop
 279     ] [
 280         >r nip [ (get-root-nodes) ] curry r> swap map
 281     ] if ;
 282
 283 : get-root-nodes ( node has-parent-relation -- root-nodes )
 284     (get-root-nodes) flatten prune ;
 285