extra/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 continuations db db.tuples db.types db.sqlite kernel math math.parser sequences ;
   4 IN: semantic-db
   5
   6 TUPLE: node id content ;
   7 : <node> ( content -- node )
   8     node new swap >>content ;
   9
  10 : <id-node> ( id -- node )
  11     node new swap >>id ;
  12
  13 node "node"
  14 {
  15     { "id" "id" +native-id+ +autoincrement+ }
  16     { "content" "content" TEXT }
  17 } define-persistent
  18
  19 : create-node-table ( -- )
  20     node create-table ;
  21
  22 : delete-node ( node-id -- )
  23     <id-node> delete-tuple ;
  24
  25 : create-node* ( str -- node-id )
  26     <node> dup insert-tuple id>> ;
  27
  28 : create-node ( str -- )
  29     create-node* drop ;
  30
  31 : node-content ( id -- str )
  32     f <node> swap >>id select-tuple content>> ;
  33
  34 TUPLE: arc id relation subject object ;
  35
  36 : <arc> ( relation subject object -- arc )
  37     arc new swap >>object swap >>subject swap >>relation ;
  38
  39 : <id-arc> ( id -- arc )
  40     arc new swap >>id ;
  41
  42 : insert-arc ( arc -- )
  43     f <node> dup insert-tuple id>> >>id insert-tuple ;
  44
  45 : delete-arc ( arc-id -- )
  46     dup delete-node <id-arc> delete-tuple ;
  47
  48 : create-arc* ( relation subject object -- arc-id )
  49     <arc> dup insert-arc id>> ;
  50
  51 : create-arc ( relation subject object -- )
  52     create-arc* drop ;
  53
  54 arc "arc"
  55 {
  56     { "id" "id" INTEGER +assigned-id+ } ! foreign key to node table?
  57     { "relation" "relation" INTEGER +not-null+ }
  58     { "subject" "subject" INTEGER +not-null+ }
  59     { "object" "object" INTEGER +not-null+ }
  60 } define-persistent
  61
  62 : create-arc-table ( -- )
  63     arc create-table ;
  64
  65 : create-bootstrap-nodes ( -- )
  66     "semantic-db" create-node
  67     "has context" create-node ;
  68
  69 : semantic-db-context 1 ;
  70 : has-context-relation 2 ;
  71
  72 : create-bootstrap-arcs ( -- )
  73     has-context-relation has-context-relation semantic-db-context create-arc ;
  74
  75 : init-semantic-db ( -- )
  76     create-node-table create-arc-table create-bootstrap-nodes create-bootstrap-arcs ;
  77
  78 : param ( value key type -- param )
  79     swapd <sqlite-low-level-binding> ;
  80
  81 : single-int-results ( bindings sql -- array )
  82     f f <simple-statement> [ do-bound-query ] with-disposal
  83     [ first string>number ] map ;
  84
  85 : ensure2 ( x y quot1 quot2 -- z )
  86     #! quot1 ( x y -- z/f ) finds an existing z
  87     #! quot2 ( x y -- z ) creates a new z if quot1 returns f
  88     >r >r 2dup r> call [ 2nip ] r> if* ;
  89