Merge branch 'frepublic' into experimental

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 combinators tools.walker
@@ -22,14 +22,22 @@ M: sqlite-db db-close ( handle -- )
 
 M: sqlite-db dispose ( db -- ) dispose-db ;
 
+: with-sqlite ( path quot -- )
+    sqlite-db swap with-db ; inline
+
+: with-tmp-sqlite ( quot -- )
+    ".db" [
+        swap with-sqlite
+    ] with-tmpfile ;
+
 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 )
     {
         set-statement-sql
         set-statement-in-params

extra/db/tuples/tuples.factor

@@ -87,6 +87,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
     ] [

extra/db/types/types.factor

@@ -195,11 +195,33 @@ TUPLE: no-slot-named ;
 : offset-of-slot ( str obj -- n )
     class slot-spec-named slot-spec-offset ;
 
+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 ;
+
 : 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 ;
 
 : 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* ;
 
 : tuple>filled-slots ( tuple -- alist )
     dup <mirror> mirror-slots [ slot-spec-name ] map

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

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

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.db ;
+USING: kernel semantic-db semantic-db.type ;
 IN: semantic-db.context
 
-: all-contexts ( -- contexts )
+! : all-contexts ( -- contexts )
-    has-type-relation context-type relation-object-subjects ;
+!     has-type-relation context-type relation-object-subjects ;
+! 
+! : context-relations ( context -- relations )
+!     has-context-relation swap relation-object-subjects ;
 
-: context-relations ( context -- relations )
+: ensure-context ( name -- context-id )
-    has-context-relation swap relation-object-subjects ;
-    
-: get-context ( name -- context )
     context-type swap ensure-node-of-type ;
 

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
@@ -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 ;
@@ -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 ;
+: add-field ( field query -- query )
-: ,field ( name table retriever -- ) <field> query get add-field ;
+    dup invalidate-query fields>> push ;
 
-: add-table ( table query -- ) invalidate-query query-tables push ;
+: add-table ( table query -- query )
-: ,table ( table -- ) query get add-table ;
+    dup invalidate-query tables>> push ;
 
-: add-condition ( condition query -- ) invalidate-query query-conditions push ;
+: add-condition ( condition query -- query )
-: ,condition ( condition -- ) query get add-condition ;
+    tuck invalidate-query conditions>> push ;
 
-: add-arg ( arg key query -- ) invalidate-query query-args set-at ;
+: add-arg ( arg key query -- query )
-: ,arg ( arg key -- ) query get add-arg ;
+    [ 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 -- )
+: prepare-query ( query -- query )
-    [ query-sql prepare ] keep set-query-statement ;
+    dup query-sql prepare >>statement ;
 
-: bind-query ( query -- )
+: bind-query ( query -- query )
-    dup query-args over query-statement bindings swap set-query-statement ;
+    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 -- )
+: retrieve ( query -- query )
-    dup query-statement over [ (retrieve) ] curry sqlite-map
+    dup statement>> over [ (retrieve) ] curry sqlite-map
-    swap set-query-results ;
+    swap >>results ;
-   ! dup query-statement over query-retriever sqlite-map swap set-query-results ;
+   ! dup query-statement over query-retriever sqlite-map swap >>results ;
 
-: finalize-query ( query -- )
+: finalize-query ( query -- query )
-    query-statement dup sqlite-finalize f swap set-query-statement ;
+    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* ;
+    dup results>> [ nip ] [ dup run-query results>> ] if* ;
-
-: with-query ( quot -- results )
-    [
-        <query> query set
-        call
-        query get get-results
-    ] with-scope ;
 
 ! 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 )
-    [
+    <query>
-        "id" "n" [ 0 column-int ] ,field
+    "id" "n" [ 0 column-int ] add-field
-        "nodes n" ,table
+    "nodes n" add-table
-        "n.name = :name" ,condition
+    "n.name = :name" add-condition
-        ":name" ,arg
+    ":name" add-arg
-        "arcs a" ,table
+    "arcs a" add-table
-        "a.relation = :has_type" ,condition
+    "a.relation = :has_type" add-condition
-        has-type-relation ":has_type" ,arg
+    has-type-relation ":has_type" add-arg
-        "a.subject = n.id" ,condition
+    "a.subject = n.id" add-condition
-        "a.object = :type" ,condition
+    "a.object = :type" add-condition
-        ":type" ,arg
+    ":type" add-arg
-        "arcs b" ,table
+    "arcs b" add-table
-        "b.subject = a.relation" ,condition
+    "b.subject = a.relation" add-condition
-        "b.relation = :has_context" ,condition
+    "b.relation = :has_context" add-condition
-        has-context-relation ":has_context" ,arg
+    has-context-relation ":has_context" add-arg
-        "b.object = :context" ,condition
+    "b.object = :context" add-condition
-        ":context" ,arg
+    ":context" add-arg
-    ] with-query 1result ;
+    get-results 1result ;
+
 
 ! ideas for an api:
 ! this would work something like jquery, where arcs can be selected according

extra/semantic-db/hierarchy/hierarchy.factor

@@ -0,0 +1,27 @@
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+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> ;

extra/semantic-db/semantic-db-tests.factor

@@ -0,0 +1,19 @@
+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
+    [ 3 ] [ "third node" create-node ] unit-test
+    [ 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

extra/semantic-db/semantic-db.factor

@@ -0,0 +1,88 @@
+! 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 math 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" +native-id+ +autoincrement+ }
+    { "content" "content" TEXT }
+} define-persistent
+
+: create-node-table ( -- )
+    node create-table ;
+
+: create-node ( content -- id )
+    <node> dup insert-tuple id>> ;
+
+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" 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 ( -- )
+    arc create-table ;
+
+: insert-arc ( arc -- )
+    dup delegate insert-tuple
+    insert-tuple ;
+   ! [ ] [ insert-sql ] make-tuple-statement insert-statement drop ;
+
+! : 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 insert-arc id>> ;
+
+: create-bootstrap-nodes ( -- )
+    { "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
+: 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-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 ;

extra/semantic-db/type/type.factor

@@ -0,0 +1,42 @@
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+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 content -- node-id )
+    create-node [ assign-type drop ] keep ;
+
+: 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 ;
+
+: 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 ;

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 - ;