From 5215e3af5f927308f9726e18c8c3b237e1a46f7a Mon Sep 17 00:00:00 2001
From: Alex Chapman <chapman.alex@gmail.com>
Date: Fri, 15 Feb 2008 17:11:28 +1100
Subject: [PATCH 1/8] io.files.tmp: update touch to use dispose instead of
 stream-close

---
 extra/io/files/tmp/tmp.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/extra/io/files/tmp/tmp.factor b/extra/io/files/tmp/tmp.factor
index da1deec9a7..a859cfdc91 100644
--- a/extra/io/files/tmp/tmp.factor
+++ b/extra/io/files/tmp/tmp.factor
@@ -7,7 +7,7 @@ IN: io.files.tmp
     "tmp" resource-path dup directory? [ dup make-directory ] unless ;
 
 : touch ( filename -- )
-    <file-writer> stream-close ;
+    <file-writer> dispose ;
 
 : tmpfile ( extension -- filename )
     16 random-alphanumeric-string over append

From a47aa3d2889686ca37a10e970c66f2db21c26263 Mon Sep 17 00:00:00 2001
From: Alex Chapman <chapman.alex@gmail.com>
Date: Mon, 18 Feb 2008 12:35:11 +1100
Subject: [PATCH 2/8] semantic-db: using new-slots

---
 extra/semantic-db/db/db.factor | 96 ++++++++++++++++------------------
 1 file changed, 45 insertions(+), 51 deletions(-)

diff --git a/extra/semantic-db/db/db.factor b/extra/semantic-db/db/db.factor
index 5616f07a1c..df8c5b4a8a 100644
--- a/extra/semantic-db/db/db.factor
+++ b/extra/semantic-db/db/db.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2007, 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs kernel math namespaces sequences sqlite ;
+USING: arrays assocs kernel math namespaces new-slots sequences sqlite ;
 IN: semantic-db.db
 
 ! sqlite utils
@@ -56,37 +56,37 @@ TUPLE: query fields tables conditions args statement results ;
     query construct-boa ;
 
 : invalidate-query ( query -- query )
-    f over set-query-results ;
+    f >>results ;
 
-: add-field ( field query -- ) invalidate-query query-fields push ;
-: ,field ( name table retriever -- ) <field> query get add-field ;
+: add-field ( field query -- query )
+    dup invalidate-query fields>> push ;
 
-: add-table ( table query -- ) invalidate-query query-tables push ;
-: ,table ( table -- ) query get add-table ;
+: add-table ( table query -- query )
+    dup invalidate-query tables>> push ;
 
-: add-condition ( condition query -- ) invalidate-query query-conditions push ;
-: ,condition ( condition -- ) query get add-condition ;
+: add-condition ( condition query -- query )
+    tuck invalidate-query conditions>> push ;
 
-: add-arg ( arg key query -- ) invalidate-query query-args set-at ;
-: ,arg ( arg key -- ) query get add-arg ;
+: add-arg ( arg key query -- query )
+    [ invalidate-query args>> set-at ] keep ;
 
 <PRIVATE
 
 : field-sql ( field -- sql )
-    [ dup field-table % CHAR: . , field-name % ] "" make ;
+    [ dup table>> % CHAR: . , name>> % ] "" make ;
 
 : fields-sql ( query -- sql )
-    query-fields dup length [
+    fields>> dup length [
         [ field-sql ] map ", " join
     ] [
         drop "*"
     ] if ;
 
 : tables-sql ( query -- sql )
-    query-tables ", " join ;
+    tables>> ", " join ;
 
 : conditions-sql ( query -- sql )
-    query-conditions dup length [
+    conditions>> dup length [
         " and " join "where " swap append
     ] [
         drop ""
@@ -97,22 +97,22 @@ TUPLE: query fields tables conditions args statement results ;
         "select" , dup fields-sql , dup "from" , tables-sql , conditions-sql ,
     ] { } make " " join ;
 
-: prepare-query ( query -- )
-    [ query-sql prepare ] keep set-query-statement ;
+: prepare-query ( query -- query )
+    dup query-sql prepare >>statement ;
 
-: bind-query ( query -- )
-    dup query-args over query-statement bindings swap set-query-statement ;
+: bind-query ( query -- query )
+    dup args>> over statement>> bindings >>statement ;
 
 : (retrieve) ( statement query -- result )
-    query-fields swap [ field-retriever call ] curry each ;
+    fields>> swap [ retriever>> call ] curry each ;
 
-: retrieve ( query -- )
-    dup query-statement over [ (retrieve) ] curry sqlite-map
-    swap set-query-results ;
-   ! dup query-statement over query-retriever sqlite-map swap set-query-results ;
+: retrieve ( query -- query )
+    dup statement>> over [ (retrieve) ] curry sqlite-map
+    swap >>results ;
+   ! dup query-statement over query-retriever sqlite-map swap >>results ;
 
-: finalize-query ( query -- )
-    query-statement dup sqlite-finalize f swap set-query-statement ;
+: finalize-query ( query -- query )
+    statement>> dup sqlite-finalize f swap >>statement ;
 
 PRIVATE>
     
@@ -120,14 +120,7 @@ PRIVATE>
     dup prepare-query dup bind-query dup retrieve finalize-query ;
 
 : get-results ( query -- results )
-    dup query-results [ nip ] [ dup run-query query-results ] if* ;
-
-: with-query ( quot -- results )
-    [
-        <query> query set
-        call
-        query get get-results
-    ] with-scope ;
+    dup results>> [ nip ] [ dup run-query results>> ] if* ;
 
 ! nodes and arcs
 
@@ -252,24 +245,25 @@ PRIVATE>
     2dup type-and-name-node [ 2nip ] [ create-node-of-type ] if* ;
 
 : type-and-name-in-context-node ( context type name -- node )
-    [
-        "id" "n" [ 0 column-int ] ,field
-        "nodes n" ,table
-        "n.name = :name" ,condition
-        ":name" ,arg
-        "arcs a" ,table
-        "a.relation = :has_type" ,condition
-        has-type-relation ":has_type" ,arg
-        "a.subject = n.id" ,condition
-        "a.object = :type" ,condition
-        ":type" ,arg
-        "arcs b" ,table
-        "b.subject = a.relation" ,condition
-        "b.relation = :has_context" ,condition
-        has-context-relation ":has_context" ,arg
-        "b.object = :context" ,condition
-        ":context" ,arg
-    ] with-query 1result ;
+    <query>
+    "id" "n" [ 0 column-int ] add-field
+    "nodes n" add-table
+    "n.name = :name" add-condition
+    ":name" add-arg
+    "arcs a" add-table
+    "a.relation = :has_type" add-condition
+    has-type-relation ":has_type" add-arg
+    "a.subject = n.id" add-condition
+    "a.object = :type" add-condition
+    ":type" add-arg
+    "arcs b" add-table
+    "b.subject = a.relation" add-condition
+    "b.relation = :has_context" add-condition
+    has-context-relation ":has_context" add-arg
+    "b.object = :context" add-condition
+    ":context" add-arg
+    get-results 1result ;
+
 
 ! ideas for an api:
 ! this would work something like jquery, where arcs can be selected according

From 1794edfa84f710f0860e208a60d01c1b45bcef25 Mon Sep 17 00:00:00 2001
From: Alex Chapman <chapman.alex@gmail.com>
Date: Tue, 19 Feb 2008 12:08:15 +1100
Subject: [PATCH 3/8] strings.lib: adding vocab for char>upper

---
 extra/strings/lib/lib.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/extra/strings/lib/lib.factor b/extra/strings/lib/lib.factor
index 6affe067fd..7f13cd58a9 100644
--- a/extra/strings/lib/lib.factor
+++ b/extra/strings/lib/lib.factor
@@ -1,4 +1,4 @@
-USING: math arrays sequences kernel random splitting strings ;
+USING: math arrays sequences kernel random splitting strings unicode.case ;
 IN: strings.lib
 
 : char>digit ( c -- i ) 48 - ;

From cfc7ef04b574596724285802381c943e91ab4e44 Mon Sep 17 00:00:00 2001
From: Alex Chapman <chapman.alex@gmail.com>
Date: Tue, 19 Feb 2008 12:09:59 +1100
Subject: [PATCH 4/8] db.sqlite: add with-tmp-sqlite, db.tuples: some fixes

---
 extra/db/sqlite/sqlite.factor |  7 ++++++-
 extra/db/tuples/tuples.factor | 33 ++++++++++++++++++++++++---------
 2 files changed, 30 insertions(+), 10 deletions(-)

diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor
index 4eabfc2ecd..17948bbbc4 100755
--- a/extra/db/sqlite/sqlite.factor
+++ b/extra/db/sqlite/sqlite.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2008 Chris Double, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien arrays assocs classes compiler db
-hashtables io.files kernel math math.parser namespaces
+hashtables io.files io.files.tmp kernel math math.parser namespaces
 prettyprint sequences strings tuples alien.c-types
 continuations db.sqlite.lib db.sqlite.ffi db.tuples
 words combinators.lib db.types ;
@@ -22,6 +22,11 @@ M: sqlite-db dispose ( db -- ) dispose-db ;
 : with-sqlite ( path quot -- )
     >r <sqlite-db> r> with-db ; inline
 
+: with-tmp-sqlite ( quot -- )
+    ".db" [
+        swap with-sqlite
+    ] with-tmpfile ;
+
 TUPLE: sqlite-statement ;
 C: <sqlite-statement> sqlite-statement
 
diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor
index 20cdd8a386..00f0f97c9e 100755
--- a/extra/db/tuples/tuples.factor
+++ b/extra/db/tuples/tuples.factor
@@ -12,23 +12,38 @@ TUPLE: no-slot-named ;
 : no-slot-named ( -- * ) T{ no-slot-named } throw ;
 
 : slot-spec-named ( str class -- slot-spec )
-    "slots" word-prop [ slot-spec-name = ] with find nip
-    [ no-slot-named ] unless* ;
+    "slots" word-prop [ slot-spec-name = ] with find nip ;
 
 : offset-of-slot ( str obj -- n )
-    class slot-spec-named slot-spec-offset ;
+    class slot-spec-named dup [ slot-spec-offset ] when ;
+
+DEFER: get-slot-named
+: get-delegate-slot-named ( str obj -- value )
+    delegate [ get-slot-named ] [ drop no-slot-named ] if* ;
 
 : get-slot-named ( str obj -- value )
-    tuck offset-of-slot [ no-slot-named ] unless* slot ;
+    2dup offset-of-slot [
+        rot drop slot
+    ] [
+        get-delegate-slot-named
+    ] if* ;
+
+DEFER: set-slot-named
+: set-delegate-slot-named ( value str obj -- )
+    delegate [ set-slot-named ] [ 2drop no-slot-named ] if* ;
 
 : set-slot-named ( value str obj -- )
-    tuck offset-of-slot [ no-slot-named ] unless* set-slot ;
+    2dup offset-of-slot [
+        rot drop set-slot
+    ] [
+        set-delegate-slot-named
+    ] if* ;
 
 : primary-key-spec ( class -- spec )
     db-columns [ primary-key? ] find nip ;
     
 : primary-key ( tuple -- obj )
-    dup class primary-key-spec get-slot-named ;
+    dup class primary-key-spec first swap get-slot-named ;
 
 : set-primary-key ( obj tuple -- )
     [ class primary-key-spec first ] keep
@@ -41,9 +56,9 @@ TUPLE: no-slot-named ;
 HOOK: create-sql db ( columns table -- seq )
 HOOK: drop-sql db ( columns table -- seq )
 
-HOOK: insert-sql* db ( columns table -- slot-names sql )
-HOOK: update-sql* db ( columns table -- slot-names sql )
-HOOK: delete-sql* db ( columns table -- slot-names sql )
+HOOK: insert-sql* db ( columns table -- sql )
+HOOK: update-sql* db ( columns table -- sql )
+HOOK: delete-sql* db ( columns table -- sql )
 HOOK: select-sql db ( tuple -- statement )
 
 HOOK: row-column-typed db ( result-set n type -- sql )

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 5/8] 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 ;
+

From aed24f565724c10e85398eff0140ffe1b104b36e Mon Sep 17 00:00:00 2001
From: Alex Chapman <chapman.alex@gmail.com>
Date: Thu, 21 Feb 2008 20:44:15 +1100
Subject: [PATCH 6/8] latest semantic-db changes

---
 extra/semantic-db/context/context.factor     | 14 ++++++------
 extra/semantic-db/hierarchy/hierarchy.factor | 23 +++++++++++++++++++-
 extra/semantic-db/semantic-db-tests.factor   | 10 ++++-----
 extra/semantic-db/semantic-db.factor         | 23 +++++++-------------
 extra/semantic-db/type/type.factor           | 19 ++++++++++++++++
 5 files changed, 61 insertions(+), 28 deletions(-)
 create mode 100644 extra/semantic-db/type/type.factor

diff --git a/extra/semantic-db/context/context.factor b/extra/semantic-db/context/context.factor
index 83da36712e..e103fbc92e 100644
--- a/extra/semantic-db/context/context.factor
+++ b/extra/semantic-db/context/context.factor
@@ -1,14 +1,14 @@
 ! Copyright (C) 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: semantic-db ;
+USING: kernel semantic-db semantic-db.type ;
 IN: semantic-db.context
 
-: all-contexts ( -- contexts )
-    has-type-relation context-type relation-object-subjects ;
+! : all-contexts ( -- contexts )
+!     has-type-relation context-type relation-object-subjects ;
+! 
+! : context-relations ( context -- relations )
+!     has-context-relation swap relation-object-subjects ;
 
-: context-relations ( context -- relations )
-    has-context-relation swap relation-object-subjects ;
-    
-: get-context ( name -- context )
+: ensure-context ( name -- context-id )
     context-type swap ensure-node-of-type ;
 
diff --git a/extra/semantic-db/hierarchy/hierarchy.factor b/extra/semantic-db/hierarchy/hierarchy.factor
index fd4f74e33c..4feb3d8d6d 100644
--- a/extra/semantic-db/hierarchy/hierarchy.factor
+++ b/extra/semantic-db/hierarchy/hierarchy.factor
@@ -1,6 +1,27 @@
 ! Copyright (C) 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel semantic-db ;
+USING: accessors kernel new-slots semantic-db semantic-db.context sequences ;
 IN: semantic-db.hierarchy
 
+TUPLE: tree id children ;
+C: <tree> tree
 
+: hierarchy-context ( -- context-id )
+    "hierarchy" ensure-context ;
+
+: has-parent-relation ( -- relation-id )
+    ! find an arc with:
+    !   type = relation (in semantic-db context)
+    !   context = hierarchy
+    !   name = "has parent"
+    ;
+
+: find-children ( node-id -- children )
+    ! find arcs with:
+    !   relation = has-parent-relation
+    !   object = node-id
+    ! then load the subjects either as nodes or subtrees
+    ;
+
+: get-node-hierarchy ( node-id -- tree )
+    dup find-children <tree> ;
diff --git a/extra/semantic-db/semantic-db-tests.factor b/extra/semantic-db/semantic-db-tests.factor
index 440335b2c3..0096b89d34 100644
--- a/extra/semantic-db/semantic-db-tests.factor
+++ b/extra/semantic-db/semantic-db-tests.factor
@@ -3,9 +3,9 @@ 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
+    [ 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
index 1205648b03..bd29dba5f8 100644
--- a/extra/semantic-db/semantic-db.factor
+++ b/extra/semantic-db/semantic-db.factor
@@ -18,12 +18,9 @@ node "node"
 : create-node-table ( -- )
     node create-table ;
 
-: create-node* ( content -- id )
+: create-node ( content -- id )
     <node> dup persist id>> ;
 
-: create-node ( content -- )
-    create-node* drop ;
-
 TUPLE: arc relation subject object ;
 
 : <arc> ( relation subject object -- arc )
@@ -41,7 +38,6 @@ arc "arc"
 
 : 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
@@ -53,15 +49,12 @@ arc "arc"
 : delete-arc ( arc -- )
     dup delete-tuple delegate delete-tuple ;
 
-: create-arc* ( relation subject object -- id )
+: 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 ;
+    [ create-node drop ] each ;
 
 : context-type 1 ; inline
 : relation-type 2 ; inline
@@ -70,11 +63,11 @@ arc "arc"
 : 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 ;
+    has-type-relation has-type-relation relation-type create-arc drop
+    has-type-relation semantic-db-context context-type create-arc drop
+    has-context-relation has-type-relation semantic-db-context create-arc drop
+    has-type-relation has-context-relation relation-type create-arc drop
+    has-context-relation has-context-relation semantic-db-context create-arc drop ;
 
 : init-semantic-db ( -- )
     create-node-table create-arc-table create-bootstrap-nodes create-bootstrap-arcs ;
diff --git a/extra/semantic-db/type/type.factor b/extra/semantic-db/type/type.factor
new file mode 100644
index 0000000000..be4da4da83
--- /dev/null
+++ b/extra/semantic-db/type/type.factor
@@ -0,0 +1,19 @@
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel semantic-db ;
+IN: semantic-db.type
+
+: assign-type ( type nid -- arc-id )
+    has-type-relation spin create-arc ;
+
+: create-node-of-type ( type name -- node-id )
+    create-node [ assign-type drop ] keep ;
+
+: select-node-of-type ( type name -- node-id? )
+    ! find a node with the given name, that is the subject of an arc with:
+    !     relation = has-type-relation
+    !     object = type
+    ;
+
+: ensure-node-of-type ( type name -- node-id )
+    2dup select-node-of-type [ 2nip ] [ create-node-of-type ] if* ;

From 0da202f1785774212fb57570b33013080ad95a87 Mon Sep 17 00:00:00 2001
From: Alex Chapman <chapman.alex@gmail.com>
Date: Fri, 29 Feb 2008 13:51:59 +1100
Subject: [PATCH 7/8] latest db and semantic-db (not really working)

---
 extra/db/sqlite/sqlite.factor              |  9 ++--
 extra/db/tuples/tuples.factor              |  7 +---
 extra/semantic-db/db/db.factor             |  2 +-
 extra/semantic-db/semantic-db-tests.factor | 10 ++++-
 extra/semantic-db/semantic-db.factor       | 48 ++++++++++++++--------
 extra/semantic-db/type/type.factor         | 35 +++++++++++++---
 6 files changed, 75 insertions(+), 36 deletions(-)

diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor
index 460b178c0e..5cb8f0c3bd 100755
--- a/extra/db/sqlite/sqlite.factor
+++ b/extra/db/sqlite/sqlite.factor
@@ -22,7 +22,7 @@ M: sqlite-db db-close ( handle -- )
 M: sqlite-db dispose ( db -- ) dispose-db ;
 
 : with-sqlite ( path quot -- )
-    >r <sqlite-db> r> with-db ; inline
+    sqlite-db swap with-db ; inline
 
 : with-tmp-sqlite ( quot -- )
     ".db" [
@@ -33,10 +33,10 @@ TUPLE: sqlite-statement ;
 
 TUPLE: sqlite-result-set has-more? ;
 
-M: sqlite-db <simple-statement> ( str -- obj )
+M: sqlite-db <simple-statement> ( str in out -- obj )
     <prepared-statement> ;
 
-M: sqlite-db <prepared-statement> ( str -- obj )
+M: sqlite-db <prepared-statement> ( str in out -- obj )
     db get db-handle 
     {
         set-statement-sql
@@ -44,7 +44,7 @@ M: sqlite-db <prepared-statement> ( str -- obj )
         set-statement-out-params
         set-statement-handle
     } statement construct
-    dup statement-handle over statement-sql sqlite-prepare
+    dup statement-handle over statement-sql sqlite-prepare over set-statement-handle
     sqlite-statement construct-delegate ;
 
 M: sqlite-statement dispose ( statement -- )
@@ -86,7 +86,6 @@ M: sqlite-result-set more-rows? ( result-set -- ? )
     sqlite-result-set-has-more? ;
 
 M: sqlite-statement query-results ( query -- result-set )
-break
     dup statement-handle sqlite-result-set <result-set>
     dup advance-row ;
 
diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor
index c775bac3ab..6c0a580980 100755
--- a/extra/db/tuples/tuples.factor
+++ b/extra/db/tuples/tuples.factor
@@ -22,12 +22,6 @@ IN: db.tuples
         class db-columns find-primary-key sql-spec-slot-name
     ] keep set-slot-named ;
 
-! : primary-key-spec ( class -- spec )
-!     db-columns [ primary-key? ] find nip ;
-!     
-! : primary-key ( tuple -- obj )
-!     dup class primary-key-spec first swap get-slot-named ;
-
 ! returns a sequence of prepared-statements
 HOOK: create-sql-statement db ( class -- obj )
 HOOK: drop-sql-statement db ( class -- obj )
@@ -81,6 +75,7 @@ HOOK: insert-tuple* db ( tuple statement -- )
     [ bind-tuple ] keep execute-statement ;
 
 : insert-tuple ( tuple -- )
+    break
     dup class db-columns find-primary-key assigned-id? [
         insert-assigned
     ] [
diff --git a/extra/semantic-db/db/db.factor b/extra/semantic-db/db/db.factor
index df8c5b4a8a..52271bfda8 100644
--- a/extra/semantic-db/db/db.factor
+++ b/extra/semantic-db/db/db.factor
@@ -35,7 +35,7 @@ M: sequence bindings
 
 : 1result ( array -- result )
     #! return the first (and hopefully only) element of the array, or f
-    dup length 0 > [ first ] [ drop f ] if ;
+    dup length zero? [ drop f ] [ first ] if ;
 
 : (collect-int-columns) ( statement n -- )
     [ dupd column-int , ] each drop ;
diff --git a/extra/semantic-db/semantic-db-tests.factor b/extra/semantic-db/semantic-db-tests.factor
index 0096b89d34..1ac4a76d3a 100644
--- a/extra/semantic-db/semantic-db-tests.factor
+++ b/extra/semantic-db/semantic-db-tests.factor
@@ -1,7 +1,9 @@
-USING: accessors db db.sqlite db.tuples kernel semantic-db tools.test ;
+USING: accessors db db.sqlite db.tuples kernel math semantic-db semantic-db.type tools.test ;
 IN: temporary
 
 [
+USE: tools.walker
+break
     create-node-table create-arc-table
     [ 1 ] [ "first node" create-node ] unit-test
     [ 2 ] [ "second node" create-node ] unit-test
@@ -9,3 +11,9 @@ IN: temporary
     [ 4 ] [ f create-node ] unit-test
     [ 5 ] [ 1 2 3 create-arc ] unit-test
 ] with-tmp-sqlite
+
+[
+    init-semantic-db
+    [ t ] [ "content" ensure-type "this is some content" ensure-node-of-type integer? ] unit-test
+    [ t ] [ "content" select-node-of-type integer? ]
+] with-tmp-sqlite
diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor
index bd29dba5f8..f6a6983ae4 100644
--- a/extra/semantic-db/semantic-db.factor
+++ b/extra/semantic-db/semantic-db.factor
@@ -1,6 +1,6 @@
 ! 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 ;
+USING: accessors arrays db db.tuples db.types db.sqlite kernel math new-slots sequences ;
 IN: semantic-db
 
 ! new semantic-db using Doug Coleman's new db abstraction library
@@ -11,7 +11,7 @@ TUPLE: node id content ;
 
 node "node"
 {
-    { "id" "id" SERIAL +native-id+ +autoincrement+ }
+    { "id" "id" +native-id+ +autoincrement+ }
     { "content" "content" TEXT }
 } define-persistent
 
@@ -19,7 +19,7 @@ node "node"
     node create-table ;
 
 : create-node ( content -- id )
-    <node> dup persist id>> ;
+    <node> dup insert-tuple id>> ;
 
 TUPLE: arc relation subject object ;
 
@@ -30,10 +30,10 @@ TUPLE: arc relation subject object ;
 
 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+ }
+    { "id" "id" INTEGER } ! foreign key to node table?
+    { "relation" "relation" INTEGER +not-null+ }
+    { "subject" "subject" INTEGER +not-null+ }
+    { "object" "object" INTEGER +not-null+ }
 } define-persistent
 
 : create-arc-table ( -- )
@@ -41,34 +41,48 @@ arc "arc"
 
 : insert-arc ( arc -- )
     dup delegate insert-tuple
-    [ ] [ insert-sql ] make-tuple-statement insert-statement drop ;
+    insert-tuple ;
+   ! [ ] [ insert-sql ] make-tuple-statement insert-statement drop ;
 
-: persist-arc ( arc -- )
-    dup primary-key [ update-tuple ] [ insert-arc ] if ;
+! : insert-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>> ;
+    <arc> dup insert-arc id>> ;
 
 : create-bootstrap-nodes ( -- )
-    { "context" "relation" "is of type" "semantic-db" "is in context" }
+    { "context" "type" "relation" "is of type" "semantic-db" "is in context" }
     [ create-node drop ] each ;
 
+! TODO: maybe put these in a 'special nodes' table
 : context-type 1 ; inline
-: relation-type 2 ; inline
-: has-type-relation 3 ; inline
-: semantic-db-context 4 ; inline
-: has-context-relation 5 ; inline
+: type-type 2 ; inline
+: relation-type 3 ; inline
+: has-type-relation 4 ; inline
+: semantic-db-context 5 ; inline
+: has-context-relation 6 ; inline
 
 : create-bootstrap-arcs ( -- )
+    ! give everything a type
+    has-type-relation context-type type-type create-arc drop
+    has-type-relation type-type type-type create-arc drop
+    has-type-relation relation-type type-type create-arc drop
     has-type-relation has-type-relation relation-type create-arc drop
     has-type-relation semantic-db-context context-type create-arc drop
-    has-context-relation has-type-relation semantic-db-context create-arc drop
     has-type-relation has-context-relation relation-type create-arc drop
+    ! give relations a context (semantic-db context)
+    has-context-relation has-type-relation semantic-db-context create-arc drop
     has-context-relation has-context-relation semantic-db-context create-arc drop ;
 
 : init-semantic-db ( -- )
     create-node-table create-arc-table create-bootstrap-nodes create-bootstrap-arcs ;
 
+: 1result ( array -- result )
+    #! return the first (and hopefully only) element of the array, or f
+    dup length zero? [ drop f ] [ first ] if ;
+
+: param ( value key type -- param )
+    rot 3array ;
diff --git a/extra/semantic-db/type/type.factor b/extra/semantic-db/type/type.factor
index be4da4da83..32c93fdb80 100644
--- a/extra/semantic-db/type/type.factor
+++ b/extra/semantic-db/type/type.factor
@@ -1,19 +1,42 @@
 ! Copyright (C) 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel semantic-db ;
+USING: arrays db db.types kernel semantic-db ;
 IN: semantic-db.type
 
 : assign-type ( type nid -- arc-id )
     has-type-relation spin create-arc ;
 
-: create-node-of-type ( type name -- node-id )
+: create-node-of-type ( type content -- node-id )
     create-node [ assign-type drop ] keep ;
 
-: select-node-of-type ( type name -- node-id? )
-    ! find a node with the given name, that is the subject of an arc with:
+: select-nodes-of-type ( type -- node-ids )
+    "type" INTEGER param
+    has-type-relation "has_type" INTEGER param 2array
+    "select a.subject from arc a where a.relation = :has_type and a.object = :type"
+    <prepared-statement> do-bound-query ;
+
+: select-node-of-type ( type -- node-id )
+    select-nodes-of-type 1array ;
+
+: select-nodes-of-type-with-content ( type content -- node-ids )
+    ! find nodes with the given content that are the subjects of arcs with:
     !     relation = has-type-relation
     !     object = type
-    ;
+    "name" TEXT param
+    swap "type" INTEGER param
+    has-type-relation "has_type" INTEGER param 3array
+    "select n.id from node n, arc a where n.content = :name and n.id = a.subject and a.object = :type and a.relation = :has_type"
+    <prepared-statement> do-bound-query ;
 
-: ensure-node-of-type ( type name -- node-id )
+: select-node-of-type-with-content ( type content -- node-id/f )
+    select-nodes-of-type-with-content 1result ;
+
+: ensure-node-of-type ( type content -- node-id )
     2dup select-node-of-type [ 2nip ] [ create-node-of-type ] if* ;
+
+: ensure-type ( type -- node-id )
+    dup "type" = [
+        drop type-type
+    ] [
+        type-type swap ensure-node-of-type
+    ] if ;

From 89b669a0588b3e2dc5c319a09310894b904cba0e Mon Sep 17 00:00:00 2001
From: Alex Chapman <chapman.alex@gmail.com>
Date: Tue, 4 Mar 2008 11:16:06 +1100
Subject: [PATCH 8/8] html.elements: add the media element property

---
 extra/html/elements/elements.factor | 1 +
 1 file changed, 1 insertion(+)

diff --git a/extra/html/elements/elements.factor b/extra/html/elements/elements.factor
index 4f9a052032..286037d4dc 100644
--- a/extra/html/elements/elements.factor
+++ b/extra/html/elements/elements.factor
@@ -161,5 +161,6 @@ SYMBOL: html
         "id" "onclick" "style" "valign" "accesskey"
         "src" "language" "colspan" "onchange" "rel"
         "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
+        "media"
     ] [ define-attribute-word ] each
 ] with-compilation-unit