From dd4a67d824e17400a3be5d22427bca7aed72a5dc Mon Sep 17 00:00:00 2001
From: Alex Chapman <chapman.alex@gmail.com>
Date: Tue, 19 Feb 2008 12:12:10 +1100
Subject: [PATCH] semantic-db: changing to use db.tuples

---
 extra/semantic-db/context/context.factor     |  2 +-
 extra/semantic-db/hierarchy/hierarchy.factor |  6 ++
 extra/semantic-db/semantic-db-tests.factor   | 11 +++
 extra/semantic-db/semantic-db.factor         | 81 ++++++++++++++++++++
 4 files changed, 99 insertions(+), 1 deletion(-)
 create mode 100644 extra/semantic-db/hierarchy/hierarchy.factor
 create mode 100644 extra/semantic-db/semantic-db-tests.factor
 create mode 100644 extra/semantic-db/semantic-db.factor

diff --git a/extra/semantic-db/context/context.factor b/extra/semantic-db/context/context.factor
index f4d5834665..83da36712e 100644
--- a/extra/semantic-db/context/context.factor
+++ b/extra/semantic-db/context/context.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: semantic-db.db ;
+USING: semantic-db ;
 IN: semantic-db.context
 
 : all-contexts ( -- contexts )
diff --git a/extra/semantic-db/hierarchy/hierarchy.factor b/extra/semantic-db/hierarchy/hierarchy.factor
new file mode 100644
index 0000000000..fd4f74e33c
--- /dev/null
+++ b/extra/semantic-db/hierarchy/hierarchy.factor
@@ -0,0 +1,6 @@
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel semantic-db ;
+IN: semantic-db.hierarchy
+
+
diff --git a/extra/semantic-db/semantic-db-tests.factor b/extra/semantic-db/semantic-db-tests.factor
new file mode 100644
index 0000000000..440335b2c3
--- /dev/null
+++ b/extra/semantic-db/semantic-db-tests.factor
@@ -0,0 +1,11 @@
+USING: accessors db db.sqlite db.tuples kernel semantic-db tools.test ;
+IN: temporary
+
+[
+    create-node-table create-arc-table
+    [ 1 ] [ "first node" create-node* ] unit-test
+    [ 2 ] [ "second node" create-node* ] unit-test
+    [ 3 ] [ "third node" create-node* ] unit-test
+    [ 4 ] [ f create-node* ] unit-test
+    [ 5 ] [ 1 2 3 create-arc* ] unit-test
+] with-tmp-sqlite
diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor
new file mode 100644
index 0000000000..1205648b03
--- /dev/null
+++ b/extra/semantic-db/semantic-db.factor
@@ -0,0 +1,81 @@
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays db db.tuples db.types db.sqlite kernel new-slots sequences ;
+IN: semantic-db
+
+! new semantic-db using Doug Coleman's new db abstraction library
+
+TUPLE: node id content ;
+: <node> ( content -- node )
+    node construct-empty swap >>content ;
+
+node "node"
+{
+    { "id" "id" SERIAL +native-id+ +autoincrement+ }
+    { "content" "content" TEXT }
+} define-persistent
+
+: create-node-table ( -- )
+    node create-table ;
+
+: create-node* ( content -- id )
+    <node> dup persist id>> ;
+
+: create-node ( content -- )
+    create-node* drop ;
+
+TUPLE: arc relation subject object ;
+
+: <arc> ( relation subject object -- arc )
+    arc construct-empty
+    f <node> over set-delegate
+    swap >>object swap >>subject swap >>relation ;
+
+arc "arc"
+{
+    { "id" "id" SERIAL +native-id+ } ! foreign key to node table?
+    { "relation" "relation" SERIAL +not-null+ }
+    { "subject" "subject" SERIAL +not-null+ }
+    { "object" "object" SERIAL +not-null+ }
+} define-persistent
+
+: create-arc-table ( -- )
+    arc create-table ;
+    ! arc db-columns maybe-remove-id arc db-table create-sql sql-command ;
+
+: insert-arc ( arc -- )
+    dup delegate insert-tuple
+    [ ] [ insert-sql ] make-tuple-statement insert-statement drop ;
+
+: persist-arc ( arc -- )
+    dup primary-key [ update-tuple ] [ insert-arc ] if ;
+
+: delete-arc ( arc -- )
+    dup delete-tuple delegate delete-tuple ;
+
+: create-arc* ( relation subject object -- id )
+    <arc> dup persist-arc id>> ;
+
+: create-arc ( relation subject object -- )
+    create-arc* drop ;
+
+: create-bootstrap-nodes ( -- )
+    { "context" "relation" "is of type" "semantic-db" "is in context" }
+    [ create-node ] each ;
+
+: context-type 1 ; inline
+: relation-type 2 ; inline
+: has-type-relation 3 ; inline
+: semantic-db-context 4 ; inline
+: has-context-relation 5 ; inline
+
+: create-bootstrap-arcs ( -- )
+    has-type-relation has-type-relation relation-type create-arc
+    has-type-relation semantic-db-context context-type create-arc
+    has-context-relation has-type-relation semantic-db-context create-arc
+    has-type-relation has-context-relation relation-type create-arc
+    has-context-relation has-context-relation semantic-db-context create-arc ;
+
+: init-semantic-db ( -- )
+    create-node-table create-arc-table create-bootstrap-nodes create-bootstrap-arcs ;
+