Merge branch 'master' of git://factorcode.org/git/factor

2008-10-01 16:32:46 -07:00 · 2008-10-01 16:32:46 -07:00 · def6c1b21f
parent 17a6a247fe 87bb2240fc
commit def6c1b21f
18 changed files with 405 additions and 52 deletions
--- a/basis/db/queries/queries.factor
+++ b/basis/db/queries/queries.factor
@ -3,7 +3,7 @@
 USING: accessors kernel math namespaces make sequences random
 strings math.parser math.intervals combinators math.bitwise
 nmake db db.tuples db.types db.sql classes words shuffle arrays
-destructors continuations db.tuples.private ;
+destructors continuations db.tuples.private prettyprint ;
 IN: db.queries

 GENERIC: where ( specs obj -- )
@ -45,11 +45,14 @@ M: retryable execute-statement* ( statement type -- )
 : sql-props ( class -- columns table )
    [ db-columns ] [ db-table ] bi ;

-: query-make ( class quot -- )
+: query-make ( class quot -- statements )
+    #! query, input, outputs, secondary queries
+    over unparse "table" set
    [ sql-props ] dip
    [ 0 sql-counter rot with-variable ] curry
-    { "" { } { } } nmake
-    <simple-statement> maybe-make-retryable ; inline
+    { "" { } { } { } } nmake
+    [ <simple-statement> maybe-make-retryable ] dip
+    [ [ 1array ] dip append ] unless-empty ; inline

 : where-primary-key% ( specs -- )
    " where " 0%
@ -145,32 +148,28 @@ M: db <delete-tuples-statement> ( tuple table -- sql )
 M: db <select-by-slots-statement> ( tuple class -- statement )
    [
        "select " 0%
-        over [ ", " 0% ]
+        [ dupd filter-ignores ] dip
+        over
+        [ ", " 0% ]
        [ dup column-name>> 0% 2, ] interleave
-
        " from " 0% 0%
        where-clause
    ] query-make ;

+: splice ( string1 string2 string3 -- string )
+    swap 3append ;
+
 : do-group ( tuple groups -- )
-    [
-        ", " join " group by " swap 3append
-    ] curry change-sql drop ;
+    [ ", " join " group by " splice ] curry change-sql drop ;

 : do-order ( tuple order -- )
-    [
-        ", " join " order by " swap 3append
-    ] curry change-sql drop ;
+    [ ", " join " order by " splice ] curry change-sql drop ;

 : do-offset ( tuple n -- )
-    [
-        number>string " offset " swap 3append
-    ] curry change-sql drop ;
+    [ number>string " offset " splice ] curry change-sql drop ;

 : do-limit ( tuple n -- )
-    [
-        number>string " limit " swap 3append
-    ] curry change-sql drop ;
+    [ number>string " limit " splice ] curry change-sql drop ;

 : make-query* ( tuple query -- tuple' )
    dupd
--- a/basis/db/sqlite/sqlite.factor
+++ b/basis/db/sqlite/sqlite.factor
@ -5,7 +5,8 @@ io.files kernel math math.parser namespaces prettyprint
 sequences strings classes.tuple alien.c-types continuations
 db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators
 math.intervals io nmake accessors vectors math.ranges random
-math.bitwise db.queries destructors db.tuples.private ;
+math.bitwise db.queries destructors db.tuples.private interpolate
+io.streams.string multiline make ;
 IN: db.sqlite

 TUPLE: sqlite-db < db path ;
@ -117,7 +118,8 @@ M: sqlite-db create-sql-statement ( class -- statement )
        dupd
        "create table " 0% 0%
        "(" 0% [ ", " 0% ] [
-            dup column-name>> 0%
+            dup "sql-spec" set
+            dup column-name>> [ "table-id" set ] [ 0% ] bi
            " " 0%
            dup type>> lookup-create-type 0%
            modifiers 0%
@ -203,9 +205,110 @@ M: sqlite-db persistent-table ( -- assoc )
        { random-generator { f f f } }
    } ;

+: insert-trigger ( -- string )
+    [
+    <"
+        CREATE TRIGGER fki_${table}_${foreign-table}_id
+        BEFORE INSERT ON ${table}
+        FOR EACH ROW BEGIN
+            SELECT RAISE(ROLLBACK, 'insert on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
+            WHERE  (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
+        END;
+    "> interpolate
+    ] with-string-writer ;
+
+: insert-trigger-not-null ( -- string )
+    [
+    <"
+        CREATE TRIGGER fki_${table}_${foreign-table}_id
+        BEFORE INSERT ON ${table}
+        FOR EACH ROW BEGIN
+            SELECT RAISE(ROLLBACK, 'insert on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
+            WHERE NEW.${foreign-table-id} IS NOT NULL
+                AND (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
+        END;
+    "> interpolate
+    ] with-string-writer ;
+
+: update-trigger ( -- string )
+    [
+    <"
+        CREATE TRIGGER fku_${table}_${foreign-table}_id
+        BEFORE UPDATE ON ${table}
+        FOR EACH ROW BEGIN
+            SELECT RAISE(ROLLBACK, 'update on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
+            WHERE  (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
+        END;
+    "> interpolate
+    ] with-string-writer ;
+
+: update-trigger-not-null ( -- string )
+    [
+    <"
+        CREATE TRIGGER fku_${table}_${foreign-table}_id
+        BEFORE UPDATE ON ${table}
+        FOR EACH ROW BEGIN
+            SELECT RAISE(ROLLBACK, 'update on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
+            WHERE NEW.${foreign-table-id} IS NOT NULL
+                AND (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
+        END;
+    "> interpolate
+    ] with-string-writer ;
+
+: delete-trigger-restrict ( -- string )
+    [
+    <"
+        CREATE TRIGGER fkd_${table}_${foreign-table}_id
+        BEFORE DELETE ON ${foreign-table}
+        FOR EACH ROW BEGIN
+            SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table}" violates foreign key constraint "fk_${foreign-table}_id"')
+            WHERE  (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
+        END;
+    "> interpolate
+    ] with-string-writer ;
+
+: delete-trigger-cascade ( -- string )
+    [
+    <"
+        CREATE TRIGGER fkd_${table}_${foreign-table}_id
+        BEFORE DELETE ON ${foreign-table}
+        FOR EACH ROW BEGIN
+            DELETE from ${table} WHERE ${table-id} = OLD.${foreign-table-id};
+        END;
+    "> interpolate
+    ] with-string-writer ;
+
+: can-be-null? ( -- ? )
+    "sql-spec" get modifiers>> [ +not-null+ = ] contains? not ;
+
+: delete-cascade? ( -- ? )
+    "sql-spec" get modifiers>> { +on-delete+ +cascade+ } swap subseq? ;
+
+: sqlite-trigger, ( string -- )
+    { } { } <simple-statement> 3, ;
+
+: create-sqlite-triggers ( -- )
+    can-be-null? [
+        insert-trigger sqlite-trigger,
+        update-trigger sqlite-trigger,
+    ] [ 
+        insert-trigger-not-null sqlite-trigger,
+        update-trigger-not-null sqlite-trigger,
+    ] if
+    delete-cascade? [
+        delete-trigger-cascade sqlite-trigger,
+    ] [
+        delete-trigger-restrict sqlite-trigger,
+    ] if ;
+
 M: sqlite-db compound ( string seq -- new-string )
    over {
        { "default" [ first number>string join-space ] }
-        { "references" [ >reference-string ] }
+        { "references" [
+            [ >reference-string ] keep
+            first2 [ "foreign-table" set ]
+            [ "foreign-table-id" set ] bi*
+            create-sqlite-triggers
+        ] }
        [ 2drop ]
    } case ;
--- a/basis/db/tuples/tuples-tests.factor
+++ b/basis/db/tuples/tuples-tests.factor
@ -176,10 +176,10 @@ SYMBOL: person4
        T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
        f H{ { 1 2 } { 3 4 } { 5 "lol" } } URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search" <user-assigned-person> person4 set ;

+
 TUPLE: paste n summary author channel mode contents timestamp annotations ;
 TUPLE: annotation n paste-id summary author mode contents ;

-: db-assigned-paste-schema ( -- )
 paste "PASTE"
 {
    { "n" "ID" +db-assigned-id+ }
@ -192,10 +192,33 @@ TUPLE: annotation n paste-id summary author mode contents ;
    { "annotations" { +has-many+ annotation } }
 } define-persistent

+: annotation-schema-foreign-key ( -- )
    annotation "ANNOTATION"
    {
        { "n" "ID" +db-assigned-id+ }
-        { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "n" }
+        { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" } }
+        { "summary" "SUMMARY" TEXT }
+        { "author" "AUTHOR" TEXT }
+        { "mode" "MODE" TEXT }
+        { "contents" "CONTENTS" TEXT }
+    } define-persistent ;
+
+: annotation-schema-foreign-key-not-null ( -- )
+    annotation "ANNOTATION"
+    {
+        { "n" "ID" +db-assigned-id+ }
+        { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" } +not-null+ }
+        { "summary" "SUMMARY" TEXT }
+        { "author" "AUTHOR" TEXT }
+        { "mode" "MODE" TEXT }
+        { "contents" "CONTENTS" TEXT }
+    } define-persistent ;
+
+: annotation-schema-cascade ( -- )
+    annotation "ANNOTATION"
+    {
+        { "n" "ID" +db-assigned-id+ }
+        { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" }
            +on-delete+ +cascade+ }
        { "summary" "SUMMARY" TEXT }
        { "author" "AUTHOR" TEXT }
@ -203,8 +226,18 @@ TUPLE: annotation n paste-id summary author mode contents ;
        { "contents" "CONTENTS" TEXT }
    } define-persistent ;

+: annotation-schema-restrict ( -- )
+    annotation "ANNOTATION"
+    {
+        { "n" "ID" +db-assigned-id+ }
+        { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" } }
+        { "summary" "SUMMARY" TEXT }
+        { "author" "AUTHOR" TEXT }
+        { "mode" "MODE" TEXT }
+        { "contents" "CONTENTS" TEXT }
+    } define-persistent ;
+
 : test-paste-schema ( -- )
-    [ ] [ db-assigned-paste-schema ] unit-test
    [ ] [ paste ensure-table ] unit-test
    [ ] [ annotation ensure-table ] unit-test
    [ ] [ annotation drop-table ] unit-test
@ -229,14 +262,38 @@ TUPLE: annotation n paste-id summary author mode contents ;
            "erg" >>author
            "annotation contents" >>contents
        insert-tuple
-    ] unit-test
+    ] unit-test ;

-    [ ] [
-    ] unit-test
-    ;
+: test-foreign-key ( -- )
+    [ ] [ annotation-schema-foreign-key ] unit-test
+    test-paste-schema
+    [ paste new 1 >>n delete-tuples ] must-fail ;

-[ test-paste-schema ] test-sqlite
-[ test-paste-schema ] test-postgresql
+: test-foreign-key-not-null ( -- )
+    [ ] [ annotation-schema-foreign-key-not-null ] unit-test
+    test-paste-schema
+    [ paste new 1 >>n delete-tuples ] must-fail ;
+
+: test-cascade ( -- )
+    [ ] [ annotation-schema-cascade ] unit-test
+    test-paste-schema
+    [ ] [ paste new 1 >>n delete-tuples ] unit-test
+    [ 0 ] [ paste new select-tuples length ] unit-test ;
+
+: test-restrict ( -- )
+    [ ] [ annotation-schema-restrict ] unit-test
+    test-paste-schema
+    [ paste new 1 >>n delete-tuples ] must-fail ;
+
+[ test-foreign-key ] test-sqlite
+[ test-foreign-key-not-null ] test-sqlite
+[ test-cascade ] test-sqlite
+[ test-restrict ] test-sqlite
+
+[ test-foreign-key ] test-postgresql
+[ test-foreign-key-not-null ] test-postgresql
+[ test-cascade ] test-postgresql
+[ test-restrict ] test-postgresql

 : test-repeated-insert
    [ ] [ person ensure-table ] unit-test
@ -293,6 +350,16 @@ TUPLE: exam id name score ;
    [ ] [ T{ exam f f "Kenny" 60 } insert-tuple ] unit-test
    [ ] [ T{ exam f f "Cartman" 41 } insert-tuple ] unit-test

+    [ 4 ]
+    [ T{ exam { name IGNORE } { score IGNORE } } select-tuples length ] unit-test
+
+    [ f ]
+    [ T{ exam { name IGNORE } { score IGNORE } } select-tuples first score>> ] unit-test
+
+    ! FIXME
+    ! [ f ]
+    ! [ T{ exam { name IGNORE } { score IGNORE } { id IGNORE } } select-tuples first score>> ] unit-test
+
    [
        {
            T{ exam f 3 "Kenny" 60 }
--- a/basis/db/types/types.factor
+++ b/basis/db/types/types.factor
@ -29,9 +29,17 @@ SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
 +foreign-id+ +has-many+ +on-delete+ +restrict+ +cascade+ +set-null+
 +set-default+ ;

+SYMBOL: IGNORE
+
+: filter-ignores ( tuple specs -- specs' )
+    [ <mirror> [ nip IGNORE = ] assoc-filter keys ] dip
+    [ slot-name>> swap member? not ] with filter ;
+
+ERROR: no-slot ;
+
 : offset-of-slot ( string tuple -- n )
    class superclasses [ "slots" word-prop ] map concat
-    slot-named offset>> ;
+    slot-named dup [ no-slot ] unless offset>> ;

 : get-slot-named ( name tuple -- value )
    tuck offset-of-slot slot ;
@ -87,9 +95,7 @@ SYMBOLS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER
 DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB
 FACTOR-BLOB NULL URL ;

-: spec>tuple ( class spec -- tuple )
-    3 f pad-right
-    [ first3 ] keep 3 tail
+: <sql-spec> ( class slot-name column-name type modifiers -- sql-spec )
    sql-spec new
        swap >>modifiers
        swap >>type
@ -98,6 +104,9 @@ FACTOR-BLOB NULL URL ;
        swap >>class
        dup normalize-spec ;

+: spec>tuple ( class spec -- tuple )
+    3 f pad-right [ first3 ] keep 3 tail <sql-spec> ;
+
 : number>string* ( n/string -- string )
    dup number? [ number>string ] when ;

@ -115,7 +124,6 @@ FACTOR-BLOB NULL URL ;
 ! PostgreSQL Types:
 ! http://developer.postgresql.org/pgdocs/postgres/datatype.html

-
 : ?at ( obj assoc -- value/obj ? )
    dupd at* [ [ nip ] [ drop ] if ] keep ;

@ -159,8 +167,11 @@ ERROR: no-sql-type type ;
 HOOK: bind% db ( spec -- )
 HOOK: bind# db ( spec obj -- )

+ERROR: no-column column ;
+
 : >reference-string ( string pair -- string )
    first2
    [ [ unparse join-space ] [ db-columns ] bi ] dip
-    swap [ slot-name>> = ] with find nip
+    swap [ column-name>> = ] with find nip
+    [ no-column ] unless*
    column-name>> paren append ;
--- a/basis/farkup/farkup.factor
+++ b/basis/farkup/farkup.factor
@ -9,6 +9,7 @@ IN: farkup
 SYMBOL: relative-link-prefix
 SYMBOL: disable-images?
 SYMBOL: link-no-follow?
+SYMBOL: line-breaks?

 TUPLE: heading1 child ;
 TUPLE: heading2 child ;
@ -29,6 +30,7 @@ TUPLE: link href text ;
 TUPLE: image href text ;
 TUPLE: code mode string ;
 TUPLE: line ;
+TUPLE: line-break ;

 : absolute-url? ( string -- ? )
    { "http://" "https://" "ftp://" } [ head? ] with contains? ;
@ -109,7 +111,9 @@ table            =  ((table-row nl => [[ first ]] )+ table-row? | table-row)
 text = (!(nl | code | heading | inline-delimiter | table ).)+
    => [[ >string ]]

-paragraph-nl-item = nl (list | line)?
+paragraph-nl-item = nl list
+    | nl line
+    | nl => [[ line-breaks? get [ drop line-break new ] when ]]
 paragraph-item = (table | code | text | inline-tag | inline-delimiter)+
 paragraph = ((paragraph-item paragraph-nl-item)+ nl+ => [[ first ]]
             | (paragraph-item paragraph-nl-item)+ paragraph-item?
@ -209,6 +213,7 @@ M: link (write-farkup) [ href>> ] [ text>> ] bi write-link ;
 M: image (write-farkup) [ href>> ] [ text>> ] bi write-image-link ;
 M: code (write-farkup) [ string>> ] [ mode>> ] bi render-code ;
 M: line (write-farkup) drop <hr/> ;
+M: line-break (write-farkup) drop <br/> nl ;
 M: table-row (write-farkup) ( obj -- )
    child>> [ [ [ (write-farkup) ] "td" in-tag. ] each ] "tr" in-tag. ;
 M: table (write-farkup) [ child>> (write-farkup) ] "table" in-tag. ;
--- a/basis/locals/locals-docs.factor
+++ b/basis/locals/locals-docs.factor
@ -85,7 +85,7 @@ HELP: MEMO::
 { POSTPONE: MEMO: POSTPONE: MEMO:: } related-words

 ARTICLE: "locals-mutable" "Mutable locals"
-"In the list of bindings supplied to " { $link POSTPONE: :: } ", " { $link POSTPONE: [let } ", " { $link POSTPONE: [let* } " or " { $link POSTPONE: [| } ", a mutable binding may be introduced by suffixing its named with " { $snippet "!" } ". Mutable bindings are read by giving their name as usual; the suffix is not part of the binding's name. To write to a mutable binding, use the binding's with the " { $snippet "!" } " suffix."
+"In the list of bindings supplied to " { $link POSTPONE: :: } ", " { $link POSTPONE: [let } ", " { $link POSTPONE: [let* } " or " { $link POSTPONE: [| } ", a mutable binding may be introduced by suffixing its named with " { $snippet "!" } ". Mutable bindings are read by giving their name as usual; the suffix is not part of the binding's name. To write to a mutable binding, use the binding's name with the " { $snippet "!" } " suffix."
 $nl
 "Here is a example word which outputs a pair of quotations which increment and decrement an internal counter, and then return the new value. The quotations are closed over the counter and each invocation of the word yields new quotations with their unique internal counter:"
 { $code
--- a/extra/html/parser/analyzer/analyzer.factor
+++ b/extra/html/parser/analyzer/analyzer.factor
@ -8,8 +8,8 @@ IN: html.parser.analyzer

 TUPLE: link attributes clickable ;

-: scrape-html ( url -- vector )
-    http-get nip parse-html ;
+: scrape-html ( url -- headers vector )
+    http-get parse-html ;

 : find-all ( seq quot -- alist )
   [ <enum> >alist ] [ '[ second @ ] ] bi* filter ; inline
--- a/extra/suffix-arrays/authors.txt
+++ b/extra/suffix-arrays/authors.txt
@ -0,0 +1 @@
+Marc Fauconneau
--- a/extra/suffix-arrays/suffix-arrays-docs.factor
+++ b/extra/suffix-arrays/suffix-arrays-docs.factor
@ -0,0 +1,45 @@
+! Copyright (C) 2008 Marc Fauconneau.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays help.markup help.syntax io.streams.string
+sequences strings math suffix-arrays.private ;
+IN: suffix-arrays
+
+HELP: >suffix-array
+{ $values
+     { "seq" sequence }
+     { "array" array } }
+{ $description "Creates a suffix array from the input sequence.  Suffix arrays are arrays of slices." } ;
+
+HELP: SA{
+{ $description "Creates a new literal suffix array at parse-time." } ;
+
+HELP: suffixes
+{ $values
+     { "string" string }
+     { "suffixes-seq" "a sequence of slices" } }
+{ $description "Returns a sequence of tail slices of the input string." } ;
+
+HELP: from-to
+{ $values
+     { "index" integer } { "begin" sequence } { "suffix-array" "a suffix-array" }
+     { "from/f" "an integer or f" } { "to/f" "an integer or f" } }
+{ $description "Finds the bounds of the suffix array that match the input sequence. A return value of " { $link f } " means that the endpoint is included." }
+{ $notes "Slices are [m,n) and we want (m,n) so we increment." } ;
+
+HELP: query
+{ $values
+     { "begin" sequence } { "suffix-array" "a suffix-array" }
+     { "matches" array } }
+{ $description "Returns a sequence of sequences from the suffix-array that contain the input sequence. An empty array is returned when there are no matches." } ;
+
+ARTICLE: "suffix-arrays" "Suffix arrays"
+"The " { $vocab-link "suffix-arrays" } " vocabulary implements the suffix array data structure for efficient lookup of subsequences. This suffix array implementation is a sorted array of suffixes. Querying it for matches uses binary search for efficiency." $nl
+
+"Creating new suffix arrays:"
+{ $subsection >suffix-array }
+"Literal suffix arrays:"
+{ $subsection POSTPONE: SA{ }
+"Querying suffix arrays:"
+{ $subsection query } ;
+
+ABOUT: "suffix-arrays"
--- a/extra/suffix-arrays/suffix-arrays-tests.factor
+++ b/extra/suffix-arrays/suffix-arrays-tests.factor
@ -0,0 +1,38 @@
+! Copyright (C) 2008 Marc Fauconneau.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test suffix-arrays kernel namespaces sequences ;
+IN: suffix-arrays.tests
+
+! built from [ all-words 10 head [ name>> ] map ]
+[ ] [ 
+     {
+        "run-tests"
+        "must-fail-with"
+        "test-all"
+        "short-effect"
+        "failure"
+        "test"
+        "<failure>"
+        "this-test"
+        "(unit-test)"
+        "unit-test"
+    } >suffix-array "suffix-array" set
+] unit-test
+
+[ t ]
+[ "suffix-array" get "" swap query empty? not ] unit-test
+
+[ { } ]
+[ SA{ } "something" swap query ] unit-test
+
+[ V{ "unit-test" "(unit-test)" } ]
+[ "suffix-array" get "unit-test" swap query ] unit-test
+
+[ t ]
+[ "suffix-array" get "something else" swap query empty? ] unit-test
+
+[ V{ "rofl" } ] [ SA{ "rofl" } "r" swap query ] unit-test
+[ V{ "rofl" } ] [ SA{ "rofl" } "o" swap query ] unit-test
+[ V{ "rofl" } ] [ SA{ "rofl" } "f" swap query ] unit-test
+[ V{ "rofl" } ] [ SA{ "rofl" } "l" swap query ] unit-test
+[ V{ } ] [ SA{ "rofl" } "t" swap query ] unit-test
--- a/extra/suffix-arrays/suffix-arrays.factor
+++ b/extra/suffix-arrays/suffix-arrays.factor
@ -0,0 +1,40 @@
+! Copyright (C) 2008 Marc Fauconneau.
+! See http://factorcode.org/license.txt for BSD license.
+USING: parser kernel arrays math accessors sequences
+math.vectors math.order sorting binary-search sets assocs fry ;
+IN: suffix-arrays
+
+<PRIVATE
+: suffixes ( string -- suffixes-seq )
+    dup length [ tail-slice ] with map ;
+
+: prefix<=> ( begin seq -- <=> )
+    [ <=> ] [ swap head? ] 2bi [ drop +eq+ ] when ;
+ 
+: find-index ( begin suffix-array -- index/f )
+    [ prefix<=> ] with search drop ;
+
+: from-to ( index begin suffix-array -- from/f to/f )
+    swap '[ _ head? not ]
+    [ find-last-from drop dup [ 1+ ] when ]
+    [ find-from drop ] 3bi ;
+
+: <funky-slice> ( from/f to/f seq -- slice )
+    [
+        tuck
+        [ drop [ 0 ] unless* ]
+        [ dupd length ? ] 2bi*
+        [ min ] keep
+    ] keep <slice> ;
+
+PRIVATE>
+
+: >suffix-array ( seq -- array )
+    [ suffixes ] map concat natural-sort ;
+
+: SA{ \ } [ >suffix-array ] parse-literal ; parsing
+
+: query ( begin suffix-array -- matches )
+    2dup find-index
+    [ -rot [ from-to ] keep <funky-slice> [ seq>> ] map prune ]
+    [ 2drop { } ] if* ;
--- a/extra/suffix-arrays/summary.txt
+++ b/extra/suffix-arrays/summary.txt
@ -0,0 +1 @@
+Suffix arrays
--- a/extra/suffix-arrays/tags.txt
+++ b/extra/suffix-arrays/tags.txt
@ -0,0 +1 @@
+collections
--- a/extra/suffix-arrays/words/words.factor
+++ b/extra/suffix-arrays/words/words.factor
@ -0,0 +1,19 @@
+! Copyright (C) 2008 Marc Fauconneau.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel arrays math accessors sequences math.vectors
+math.order sorting binary-search sets assocs fry suffix-arrays ;
+IN: suffix-arrays.words
+
+! to search on word names
+
+: new-word-sa ( words -- sa )
+    [ name>> ] map >suffix-array ;
+
+: name>word-map ( words -- map )
+    dup [ name>> V{ } clone ] H{ } map>assoc
+    [ '[ dup name>> _ at push ] each ] keep ;
+
+: query-word-sa ( map begin sa -- matches ) query '[ _ at ] map concat ;
+
+! usage example :
+! clear all-words 100 head dup name>word-map "test" rot new-word-sa query .
--- a/extra/webapps/irc-log/authors.txt
+++ b/extra/webapps/irc-log/authors.txt
@ -0,0 +1 @@
+Doug Coleman
--- a/extra/webapps/irc-log/irc-log.factor
+++ b/extra/webapps/irc-log/irc-log.factor
@ -0,0 +1,22 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: calendar kernel http.server.dispatchers prettyprint
+sequences printf furnace.actions html.forms accessors
+furnace.redirection ;
+IN: webapps.irc-log
+
+TUPLE: irclog-app < dispatcher ;
+
+: irc-link ( -- string )   
+    gmt -7 hours convert-timezone >date<
+    [ unparse 2 tail ] 2dip
+    "http://bespin.org/~nef/logs/concatenative/%02s.%02d.%02d"
+    sprintf ;
+    
+: <display-irclog-action> ( -- action )
+    <action>
+        [ irc-link <redirect> ] >>display ;
+
+: <irclog-app> ( -- dispatcher )
+    irclog-app new-dispatcher
+        <display-irclog-action> "" add-responder ;
--- a/unfinished/sql/sql-tests.factor
+++ b/unfinished/sql/sql-tests.factor
--- a/unfinished/sql/sql.factor
+++ b/unfinished/sql/sql.factor