diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor index f7809de578..17d8870990 100644 --- 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 - maybe-make-retryable ; inline + { "" { } { } { } } nmake + [ maybe-make-retryable ] dip + [ [ 1array ] dip append ] unless-empty ; inline : where-primary-key% ( specs -- ) " where " 0% @@ -145,32 +148,28 @@ M: db ( tuple table -- sql ) M: db ( 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 diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index aab1e5f40f..dfd9fab08c 100755 --- 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 -- ) + { } { } 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 ; diff --git a/basis/db/tuples/tuples-tests.factor b/basis/db/tuples/tuples-tests.factor index 6a5e78aa4b..6114c7ebe1 100755 --- a/basis/db/tuples/tuples-tests.factor +++ b/basis/db/tuples/tuples-tests.factor @@ -176,26 +176,49 @@ 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" 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+ } - { "summary" "SUMMARY" TEXT } - { "author" "AUTHOR" TEXT } - { "channel" "CHANNEL" TEXT } - { "mode" "MODE" TEXT } - { "contents" "CONTENTS" TEXT } - { "timestamp" "DATE" TIMESTAMP } - { "annotations" { +has-many+ annotation } } - } define-persistent +paste "PASTE" +{ + { "n" "ID" +db-assigned-id+ } + { "summary" "SUMMARY" TEXT } + { "author" "AUTHOR" TEXT } + { "channel" "CHANNEL" TEXT } + { "mode" "MODE" TEXT } + { "contents" "CONTENTS" TEXT } + { "timestamp" "DATE" TIMESTAMP } + { "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 } diff --git a/basis/db/types/types.factor b/basis/db/types/types.factor index bc33792e52..ac9e3397f8 100755 --- 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' ) + [ [ 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,16 +95,17 @@ 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 +: ( class slot-name column-name type modifiers -- sql-spec ) sql-spec new swap >>modifiers swap >>type swap >>column-name swap >>slot-name swap >>class - dup normalize-spec ; + dup normalize-spec ; + +: spec>tuple ( class spec -- tuple ) + 3 f pad-right [ first3 ] keep 3 tail ; : 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 ; diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor index 73b0cba4d0..21e3c05d04 100644 --- 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
; +M: line-break (write-farkup) drop
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. ; diff --git a/basis/locals/locals-docs.factor b/basis/locals/locals-docs.factor index 3dfc17c081..eb368936d4 100644 --- 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 diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index 5c640c6fb9..38dd9225fe 100755 --- 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 ) [ >alist ] [ '[ second @ ] ] bi* filter ; inline diff --git a/extra/suffix-arrays/authors.txt b/extra/suffix-arrays/authors.txt new file mode 100755 index 0000000000..e4a36df7ef --- /dev/null +++ b/extra/suffix-arrays/authors.txt @@ -0,0 +1 @@ +Marc Fauconneau \ No newline at end of file diff --git a/extra/suffix-arrays/suffix-arrays-docs.factor b/extra/suffix-arrays/suffix-arrays-docs.factor new file mode 100755 index 0000000000..87df27281e --- /dev/null +++ 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" diff --git a/extra/suffix-arrays/suffix-arrays-tests.factor b/extra/suffix-arrays/suffix-arrays-tests.factor new file mode 100755 index 0000000000..5149804ce6 --- /dev/null +++ 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" + "" + "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 diff --git a/extra/suffix-arrays/suffix-arrays.factor b/extra/suffix-arrays/suffix-arrays.factor new file mode 100755 index 0000000000..719496243c --- /dev/null +++ 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 + + ( 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 ; + +: ( from/f to/f seq -- slice ) + [ + tuck + [ drop [ 0 ] unless* ] + [ dupd length ? ] 2bi* + [ min ] keep + ] keep ; + +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 [ seq>> ] map prune ] + [ 2drop { } ] if* ; diff --git a/extra/suffix-arrays/summary.txt b/extra/suffix-arrays/summary.txt new file mode 100755 index 0000000000..71eda476bc --- /dev/null +++ b/extra/suffix-arrays/summary.txt @@ -0,0 +1 @@ +Suffix arrays diff --git a/extra/suffix-arrays/tags.txt b/extra/suffix-arrays/tags.txt new file mode 100755 index 0000000000..42d711b32b --- /dev/null +++ b/extra/suffix-arrays/tags.txt @@ -0,0 +1 @@ +collections diff --git a/extra/suffix-arrays/words/words.factor b/extra/suffix-arrays/words/words.factor new file mode 100755 index 0000000000..74e2fc2f97 --- /dev/null +++ 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 . diff --git a/extra/webapps/irc-log/authors.txt b/extra/webapps/irc-log/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/webapps/irc-log/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/webapps/irc-log/irc-log.factor b/extra/webapps/irc-log/irc-log.factor new file mode 100644 index 0000000000..c193550719 --- /dev/null +++ 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 ; + +: ( -- action ) + + [ irc-link ] >>display ; + +: ( -- dispatcher ) + irclog-app new-dispatcher + "" add-responder ; diff --git a/basis/db/sql/sql-tests.factor b/unfinished/sql/sql-tests.factor similarity index 100% rename from basis/db/sql/sql-tests.factor rename to unfinished/sql/sql-tests.factor diff --git a/basis/db/sql/sql.factor b/unfinished/sql/sql.factor similarity index 100% rename from basis/db/sql/sql.factor rename to unfinished/sql/sql.factor