{ $subsection sql-query }
"Here's an example usage where we'll make a book table, insert some objects, and query them." $nl
"First, let's set up a custom combinator for using our database. See " { $link "db-custom-database-combinators" } " for more details."
-{ $code "
+{ $code """
USING: db.sqlite db io.files io.files.temp ;
: with-book-db ( quot -- )
"book.db" temp-file <sqlite-db> swap with-db ; inline" }
{ $code " "create table books
(id integer primary key, title text, author text, date_published timestamp,
edition integer, cover_price double, condition text)"
- [ sql-command ] with-book-db" }
+ [ sql-command ] with-book-db""" }
"Time to insert some books:"
-{ $code "
+{ $code """
"insert into books
(title, author, date_published, edition, cover_price, condition)
values('Factor for Sheeple', 'Mister Stacky Pants', date('now'), 1, 13.37, 'mint')"
-[ sql-command ] with-book-db" }
+[ sql-command ] with-book-db""" }
"Now let's select the book:"
-{ $code "
-"select id, title, cover_price from books;" [ sql-query ] with-book-db " }
+{ $code """
+"select id, title, cover_price from books;" [ sql-query ] with-book-db""" }
"Notice that the result of this query is a Factor array containing the database rows as arrays of strings. We would have to convert the " { $snippet "cover_price" } " from a string to a number in order to use it in a calculation." $nl
"In conclusion, this method of accessing a database is supported, but it is fairly low-level and generally specific to a single database. The " { $vocab-link "db.tuples" } " vocabulary is a good alternative to writing SQL by hand." ;
"Make a " { $snippet "with-" } " combinator to open and close a database so that resources are not leaked." $nl
"SQLite example combinator:"
-{ $code "
+{ $code """
USING: db.sqlite db io.files io.files.temp ;
: with-sqlite-db ( quot -- )
- "my-database.db" temp-file <sqlite-db> swap with-db ; inline" }
+ "my-database.db" temp-file <sqlite-db> swap with-db ; inline""" }
"PostgreSQL example combinator:"
-{ $code " USING: db.postgresql db ;
+{ $code """USING: db.postgresql db ;
: with-postgresql-db ( quot -- )
<postgresql-db>
"localhost" >>host
"erg" >>username
"secrets?" >>password
"factor-test" >>database
- swap with-db ; inline"
+ swap with-db ; inline"""
} ;
ABOUT: "db"
: insert-trigger ( -- string )
[
- "
+ """
CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE INSERT ON ${table-name}
FOR EACH ROW BEGIN
SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fki_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
END;
- " interpolate
+ """ interpolate
] with-string-writer ;
: insert-trigger-not-null ( -- string )
[
- "
+ """
CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE INSERT ON ${table-name}
FOR EACH ROW BEGIN
WHERE NEW.${table-id} IS NOT NULL
AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
END;
- " interpolate
+ """ interpolate
] with-string-writer ;
: update-trigger ( -- string )
[
- "
+ """
CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE UPDATE ON ${table-name}
FOR EACH ROW BEGIN
SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fku_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
END;
- " interpolate
+ """ interpolate
] with-string-writer ;
: update-trigger-not-null ( -- string )
[
- "
+ """
CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE UPDATE ON ${table-name}
FOR EACH ROW BEGIN
WHERE NEW.${table-id} IS NOT NULL
AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
END;
- " interpolate
+ """ interpolate
] with-string-writer ;
: delete-trigger-restrict ( -- string )
[
- "
+ """
CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE DELETE ON ${foreign-table-name}
FOR EACH ROW BEGIN
SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table-name}" violates foreign key constraint "fkd_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
END;
- " interpolate
+ """ interpolate
] with-string-writer ;
: delete-trigger-cascade ( -- string )
-
- "
+ [
+ """
CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE DELETE ON ${foreign-table-name}
FOR EACH ROW BEGIN
DELETE from ${table-name} WHERE ${table-id} = OLD.${foreign-table-id};
END;
- " interpolate
+ """ interpolate
] with-string-writer ;
: can-be-null? ( -- ? )
M: bad-effect summary
drop "Bad stack effect declaration" ;
-M: bad-escape summary drop "Bad escape code" ;
+M: bad-escape error.
+ "Bad escape code: \\" write
+ char>> 1string print ;
M: bad-literal-tuple summary drop "Bad literal tuple" ;
-USING: help.markup help.syntax sequences math math.vectors
-classes.tuple.private
-math.vectors.simd.intrinsics cpu.architecture ;
+USING: classes.tuple.private cpu.architecture help.markup
+help.syntax kernel.private math math.vectors
+math.vectors.simd.intrinsics sequences ;
IN: math.vectors.simd
ARTICLE: "math.vectors.simd.intro" "Introduction to SIMD support"
;
[ "foo\nbar\n" ] [ test-it ] unit-test
-[ "foo\nbar\n" ] [ <" foo
-bar
-"> ] unit-test
-
-[ "hello\nworld" ] [ <" hello
-world"> ] unit-test
-
-[ "hello" "world" ] [ <" hello"> <" world"> ] unit-test
-
-[ "\nhi" ] [ <"
-hi"> ] unit-test
! HEREDOC:
}
{ $description "Randomizes a sequence in-place with the Fisher-Yates algorithm and returns the sequence." } ;
+HELP: sample
+{ $values
+ { "seq" sequence } { "n" integer }
+ { "seq'" sequence }
+}
+{ $description "Takes " { $snippet "n" } " samples at random without replacement from a sequence. Throws an error if " { $snippet "n" } " is longer than the sequence." }
+{ $examples
+ { $unchecked-example "USING: random prettyprint ; { 1 2 3 } 2 sample ."
+ "{ 3 2 }"
+ }
+} ;
+
HELP: delete-random
{ $values
{ "seq" sequence }
{ $subsection "random-protocol" }
"Randomizing a sequence:"
{ $subsection randomize }
+"Sampling a sequences:"
+{ $subsection sample }
"Deleting a random element from a sequence:"
{ $subsection delete-random }
"Random numbers with " { $snippet "n" } " bits:"
[ 100 [ { 0 1 } random ] replicate all-equal? ] unit-test
[ 49 ] [ 50 random-bits* log2 ] unit-test
+
+[ { 1 2 } 3 sample ] [ too-many-samples? ] must-fail-with
+
+[ 3 ] [ { 1 2 3 4 } 3 sample prune length ] unit-test
+[ 99 ] [ 100 99 sample prune length ] unit-test
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types kernel math namespaces sequences
-io.backend io.binary combinators system vocabs.loader
-summary math.bitwise byte-vectors fry byte-arrays
-math.ranges math.constants math.functions accessors ;
+USING: accessors alien.c-types assocs byte-arrays byte-vectors
+combinators fry io.backend io.binary kernel locals math
+math.bitwise math.constants math.functions math.ranges
+namespaces sequences sets summary system vocabs.loader ;
IN: random
SYMBOL: system-random-generator
[ [ iota random ] [ 1 - ] bi [ pick exchange ] keep ]
while drop ;
+ERROR: too-many-samples seq n ;
+
+<PRIVATE
+
+:: next-sample ( length n seq hashtable -- elt )
+ n hashtable key? [
+ length n 1 + length mod seq hashtable next-sample
+ ] [
+ n hashtable conjoin
+ n seq nth
+ ] if ;
+
+PRIVATE>
+
+: sample ( seq n -- seq' )
+ 2dup [ length ] dip < [ too-many-samples ] when
+ swap [ length ] [ ] bi H{ } clone
+ '[ _ dup random _ _ next-sample ] replicate ;
+
: delete-random ( seq -- elt )
[ length random-integer ] keep [ nth ] 2keep delete-nth ;
! Copyright (C) 2008, 2009 Daniel Ehrenberg, Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: wrap.strings tools.test multiline ;
+USING: wrap.strings tools.test ;
IN: wrap.strings.tests
[
- <" This is a
+ """This is a
long piece
of text
that we
wish to
-word wrap.">
+word wrap."""
] [
- <" This is a long piece of text that we wish to word wrap."> 10
+ """This is a long piece of text that we wish to word wrap.""" 10
wrap-string
] unit-test
[
- <" This is a
+ """ This is a
long piece
of text
that we
wish to
- word wrap.">
+ word wrap."""
] [
- <" This is a long piece of text that we wish to word wrap."> 12
+ """This is a long piece of text that we wish to word wrap.""" 12
" " wrap-indented-string
] unit-test
"one two three" " " split
[ [XML <item><-></item> XML] ] map
<XML <doc><-></doc> XML> pprint-xml"""
+
"""<?xml version="1.0" encoding="UTF-8"?>
<doc>
<item>
false [ f ]
url [ URL" http://factorcode.org/" ]
string [ "hello" ]
- word [ \ drop ] |
+ word [ \\ drop ] |
<XML
<x
number=<-number->
url=<-url->
string=<-string->
word=<-word-> />
- XML> pprint-xml ]"""
+ XML> pprint-xml
+]"""
+
"""<?xml version="1.0" encoding="UTF-8"?>
<x number="3" url="http://factorcode.org/" string="hello" word="drop"/>""" }
"XML interpolation can also be used, in conjunction with " { $vocab-link "inverse" } " in pattern matching. For example:"
{ [ [XML <b val='yes'/> XML] ] [ "yes" ] }
{ [ [XML <b val=<->/> XML] ] [ "no" prepend ] }
} switch ;
-[XML <a>pple</a> XML] dispatch write""" "apple" } ;
+[XML <a>pple</a> XML] dispatch write"""
+"apple" } ;
HELP: XML-NS:
{ $syntax "XML-NS: name http://url" }
{ $example """USING: xml.syntax xml.writer namespaces ;
[XML <html> <head> <title> something</title></head><body><pre>bing
bang
- bong</pre></body></html> XML] { "pre" } sensitive-tags [ pprint-xml ] with-variable "} {"
+ bong</pre></body></html> XML] { "pre" } sensitive-tags [ pprint-xml ] with-variable"""
+"""
<html>
<head>
<title>
math.order ;
IN: strings.parser
-ERROR: bad-escape ;
+ERROR: bad-escape char ;
: escape ( escape -- ch )
H{
{ CHAR: 0 CHAR: \0 }
{ CHAR: \\ CHAR: \\ }
{ CHAR: \" CHAR: \" }
- } at [ bad-escape ] unless* ;
+ } ?at [ bad-escape ] unless ;
SYMBOL: name>char-hook
} ;
HELP: "
-{ $syntax "\"string...\"" }
-{ $syntax "\"\"\"string...\"\"\"" }
+{ $syntax "\"string...\"" "\"\"\"string...\"\"\"" }
{ $values { "string" "literal and escaped characters" } }
-{ $description "Reads from the input string until the next occurrence of " { $link POSTPONE: " } " or " { $snippet "\"\"\"" } ", and appends the resulting string to the parse tree. String literals can span multiple lines. For strings beginning with a single double-quote, the " { $link POSTPONE: " } " character and various other special characters can be read by inserting " { $link "escape" } ". For triple quoted strings, the double-quote character does not require escaping." }
+{ $description "Reads from the input string until the next occurrence of " { $snippet "\"" } " or " { $snippet "\"\"\"" } ", and appends the resulting string to the parse tree. String literals can span multiple lines. Various special characters can be read by inserting " { $link "escape" } ". For triple quoted strings, the double-quote character does not require escaping." }
{ $examples
- "A string with a newline in it:"
+ "A string with an escaped newline in it:"
{ $example "USE: io" "\"Hello\\nworld\" print" "Hello\nworld" }
+ "A string with an actual newline in it:"
+ { $example "USE: io" "\"Hello\nworld\" print" "Hello\nworld" }
"A string with a named Unicode code point:"
{ $example "USE: io" "\"\\u{greek-capital-letter-sigma}\" print" "\u{greek-capital-letter-sigma}" }
"A triple-quoted string:"
- { $example "USE: io \"\"\"\"Teach a man to fish...\"\"\"\" print" """"Teach a man to fish..."""" }
+ { $example "USE: io \"\"\"Teach a man to \"fish\"...\nand fish will go extinct\"\"\" print" """Teach a man to \"fish\"...
+and fish will go extinct""" }
} ;
HELP: SBUF"
--- /dev/null
+IN: rpn.tests
+USING: rpn lists tools.test ;
+
+[ { 2 } ] [ "4 2 -" rpn-parse rpn-eval list>array ] unit-test
\ No newline at end of file
GENERIC: eval-insn ( stack insn -- stack )
: binary-op ( stack quot: ( x y -- z ) -- stack )
- [ uncons uncons ] dip dip cons ; inline
+ [ uncons uncons [ swap ] dip ] dip dip cons ; inline
M: add-insn eval-insn drop [ + ] binary-op ;
M: sub-insn eval-insn drop [ - ] binary-op ;
: print-stack ( list -- )
[ number>string print ] leach ;
-: rpn-eval ( tokens -- )
- nil [ eval-insn ] foldl print-stack ;
+: rpn-eval ( tokens -- stack )
+ nil [ eval-insn ] foldl ;
: rpn ( -- )
"RPN> " write flush
- readln [ rpn-parse rpn-eval rpn ] when* ;
+ readln [ rpn-parse rpn-eval print-stack rpn ] when* ;
MAIN: rpn
{ $description "Constructs a " { $link product-sequence } " over " { $snippet "sequences" } "." }
{ $examples
{ $example """USING: arrays prettyprint sequences.product ;
-{ { 1 2 3 } { "a" "b" "c" } } <product-sequence> >array .
-""" """ {
+{ { 1 2 3 } { "a" "b" "c" } } <product-sequence> >array ."""
+"""{
{ 1 "a" }
{ 2 "a" }
{ 3 "a" }
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: smtp namespaces accessors kernel arrays ;
+USING: smtp namespaces accessors kernel arrays site-watcher.db ;
IN: site-watcher.email
SYMBOL: site-watcher-from
pick [
[ <email> site-watcher-from get >>from ] 3dip
[ 1array >>to ] [ >>body ] [ >>subject ] tri* send-email
- ] [ 3drop ] if ;
\ No newline at end of file
+ ] [ 3drop ] if ;
! (c)2009 Joe Groff, see BSD license
USING: accessors arrays literals math math.affine-transforms
-math.functions sequences svg tools.test xml xml.traversal ;
+math.functions sequences svg tools.test xml xml.traversal multiline ;
IN: svg.tests
{ 1.0 2.25 } { -3.0 4.0 } { 5.5 0.5 } <affine-transform> 1array [
projects / factor.git / commitdiff