diff --git a/basis/db/db-docs.factor b/basis/db/db-docs.factor new file mode 100644 index 0000000000..9c3a643ef0 --- /dev/null +++ b/basis/db/db-docs.factor @@ -0,0 +1,153 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: classes kernel help.markup help.syntax sequences +alien assocs strings math multiline ; +IN: db + +HELP: db +{ $description "The " { $snippet "db" } " class is the superclass of all other database classes. It stores a " { $snippet "handle" } " to the database as well as insert, update, and delete queries." } ; + +HELP: new-db +{ $values { "class" class } { "obj" object } } +{ $description "Creates a new database object from a given class." } ; + +HELP: make-db* +{ $values { "seq" sequence } { "db" object } { "db" object } } +{ $description "Takes a sequence of parameters specific to each database and a class name of the database, and constructs a new database object." } ; + +HELP: make-db +{ $values { "seq" sequence } { "class" class } { "db" db } } +{ $description "Takes a sequence of parameters specific to each database and a class name of the database, and constructs a new database object." } ; + +HELP: db-open +{ $values { "db" db } { "db" db } } +{ $description "Opens a database using the configuration data stored in a " { $link db } " tuple." } ; + +HELP: db-close +{ $values { "handle" alien } } +{ $description "Closes a database using the handle provided." } ; + +HELP: dispose-statements +{ $values { "assoc" assoc } } +{ $description "Disposes an associative list of statements." } ; + +HELP: db-dispose +{ $values { "db" db } } +{ $description "Disposes of all the statements stored in the " { $link db } " object." } ; + +HELP: statement +{ $description "A " { $snippet "statement" } " stores the information about a statemen, such as the SQL statement text, the in/out parameters, and type information." } ; + +HELP: simple-statement +{ $description } ; + +HELP: prepared-statement +{ $description } ; + +HELP: result-set +{ $description } ; + +HELP: construct-statement +{ $values { "sql" string } { "in" sequence } { "out" sequence } { "class" class } { "statement" statement } } +{ $description "Makes a new statement object from the given parameters." } ; + +HELP: +{ $values { "string" string } { "in" sequence } { "out" sequence } } +{ $description "Makes a new simple statement object from the given parameters." } ; + +HELP: +{ $values { "string" string } { "in" sequence } { "out" sequence } } +{ $description "Makes a new prepared statement object from the given parameters." } ; + +HELP: prepare-statement +{ $values { "statement" statement } } +{ $description "For databases which implement a method on this generic, it does some internal processing to ready the statement for execution." } ; + +HELP: bind-statement* +{ $values { "statement" statement } } +{ $description "" } ; + +HELP: low-level-bind +{ $values { "statement" statement } } +{ $description "" } ; + +HELP: bind-tuple +{ $values { "tuple" tuple } { "statement" statement } } +{ $description "" } ; + +HELP: query-results +{ $values { "query" object } { "statement" statement } } +{ $description "" } ; + +HELP: #rows +{ $values { "result-set" result-set } { "n" integer } } +{ $description "Returns the number of rows in a result set." } ; + +HELP: #columns +{ $values { "result-set" result-set } { "n" integer } } +{ $description "Returns the number of columns in a result set." } ; + +HELP: row-column +{ $values { "result-set" result-set } { "column" integer } } +{ $description "" } ; + +HELP: row-column-typed +{ $values { "result-set" result-set } { "column" integer } } +{ $description "" } ; + +HELP: advance-row +{ $values { "result-set" result-set } } +; + +HELP: more-rows? +{ $values { "result-set" result-set } { "column" integer } } +; + +HELP: execute-statement* +{ $values { "statement" statement } { "type" object } } +{ $description } ; + +HELP: execute-statement +{ $values { "statement" statement } } +{ $description } ; + +ARTICLE: "db" "Low-level database library" +{ $subsection "db-custom-database-combinators" } +{ $subsection "db-protocol" } +{ $subsection "db-lowlevel-tutorial" } +"Higher-level database:" +{ $vocab-subsection "Database types" "db.types" } +{ $vocab-subsection "High-level tuple/database integration" "db.tuples" } +"Supported database backends:" +{ $vocab-subsection "SQLite" "db.sqlite" } +{ $vocab-subsection "PostgreSQL" "db.postgresql" } +"To add support for another database to Factor:" +{ $subsection "db-porting-the-library" } +; + +ARTICLE: "db-protocol" "Low-level database protocol" +"The high-level protocol (see " { $vocab-link "db.tuples" } ") uses this low-level protocol for executing statements and queries." +; + +ARTICLE: "db-lowlevel-tutorial" "Low-level database tutorial" +"Although Factor makes integrating a database with its object system easy (see " { $vocab-link "db.tuples" } "), sometimes you may want to write SQL directly and get the results back as arrays of strings, for instance, when interfacing with a legacy database that doesn't easily map to " { $snippet "tuples" } "." +; + +ARTICLE: "db-porting-the-library" "Porting the database library" +"This section is not yet written." +; + + +ARTICLE: "db-custom-database-combinators" "Custom database combinators" +"Every database library requires some effort on the programmer's part to initialize and open a database. SQLite uses files on your harddisk, so a simple pathname is all the setup required. With PostgreSQL, you log in to a networked server as a user on a specfic port." $nl + +"Make a " { $snippet "with-" } " word to open, close, and use your database." +{ $code <" +: with-my-database ( quot -- ) + { "my-database.db" temp-file } +"> } + + +; + +ABOUT: "db" diff --git a/basis/db/db.factor b/basis/db/db.factor index 10da653c9f..26141ec62c 100755 --- a/basis/db/db.factor +++ b/basis/db/db.factor @@ -105,10 +105,10 @@ M: object execute-statement* ( statement type -- ) ] if ; inline recursive : query-map ( statement quot -- seq ) - accumulator >r query-each r> { } like ; inline + accumulator [ query-each ] dip { } like ; inline : with-db ( seq class quot -- ) - >r make-db db-open db r> + [ make-db db-open db ] dip [ db get swap [ drop ] prepose with-disposal ] curry with-variable ; inline diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor index a28f283d30..023ef3d9a8 100644 --- a/basis/db/queries/queries.factor +++ b/basis/db/queries/queries.factor @@ -2,15 +2,49 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel math namespaces sequences random strings math.parser math.intervals combinators math.bitwise nmake db -db.tuples db.types db.sql classes words shuffle arrays ; +db.tuples db.types db.sql classes words shuffle arrays destructors +continuations ; IN: db.queries GENERIC: where ( specs obj -- ) +SINGLETON: retryable +: make-retryable ( obj -- obj' ) + dup sequence? [ + [ make-retryable ] map + ] [ + retryable >>type + 10 >>retries + ] if ; + : maybe-make-retryable ( statement -- statement ) dup in-params>> [ generator-bind? ] contains? [ make-retryable ] when ; +: regenerate-params ( statement -- statement ) + dup + [ bind-params>> ] [ in-params>> ] bi + [ + dup generator-bind? [ + generator-singleton>> eval-generator >>value + ] [ + drop + ] if + ] 2map >>bind-params ; + +M: retryable execute-statement* ( statement type -- ) + drop [ retries>> ] [ + [ + nip + [ query-results dispose t ] + [ ] + [ regenerate-params bind-statement* f ] cleanup + ] curry + ] bi attempt-all drop ; + +: sql-props ( class -- columns table ) + [ db-columns ] [ db-table ] bi ; + : query-make ( class quot -- ) >r sql-props r> [ 0 sql-counter rot with-variable ] curry { "" { } { } } nmake diff --git a/basis/db/sql/sql.factor b/basis/db/sql/sql.factor index 06428485e1..2496ac6f3a 100755 --- a/basis/db/sql/sql.factor +++ b/basis/db/sql/sql.factor @@ -1,6 +1,6 @@ USING: kernel parser quotations classes.tuple words math.order nmake namespaces sequences arrays combinators -prettyprint strings math.parser math symbols ; +prettyprint strings math.parser math symbols db ; IN: db.sql SYMBOLS: insert update delete select distinct columns from as @@ -23,44 +23,142 @@ DEFER: sql% : sql-function, ( seq function -- ) sql% "(" sql% unclip sql% ")" sql% [ sql% ] each ; -: sql-where ( seq -- ) -B +: sql-where, ( seq -- ) [ [ second 0, ] [ first 0, ] [ third 1, \ ? 0, ] tri ] each ; +USE: multiline +/* +HOOK: sql-create db ( object -- ) +M: db sql-create ( object -- ) + drop + "create table" sql% ; + +HOOK: sql-drop db ( object -- ) +M: db sql-drop ( object -- ) + drop + "drop table" sql% ; + +HOOK: sql-insert db ( object -- ) +M: db sql-insert ( object -- ) + drop + "insert into" sql% ; + +HOOK: sql-update db ( object -- ) +M: db sql-update ( object -- ) + drop + "update" sql% ; + +HOOK: sql-delete db ( object -- ) +M: db sql-delete ( object -- ) + drop + "delete" sql% ; + +HOOK: sql-select db ( object -- ) +M: db sql-select ( object -- ) + "select" sql% "," (sql-interleave) ; + +HOOK: sql-columns db ( object -- ) +M: db sql-columns ( object -- ) + "," (sql-interleave) ; + +HOOK: sql-from db ( object -- ) +M: db sql-from ( object -- ) + "from" "," sql-interleave ; + +HOOK: sql-where db ( object -- ) +M: db sql-where ( object -- ) + "where" 0, sql-where, ; + +HOOK: sql-group-by db ( object -- ) +M: db sql-group-by ( object -- ) + "group by" "," sql-interleave ; + +HOOK: sql-having db ( object -- ) +M: db sql-having ( object -- ) + "having" "," sql-interleave ; + +HOOK: sql-order-by db ( object -- ) +M: db sql-order-by ( object -- ) + "order by" "," sql-interleave ; + +HOOK: sql-offset db ( object -- ) +M: db sql-offset ( object -- ) + "offset" sql% sql% ; + +HOOK: sql-limit db ( object -- ) +M: db sql-limit ( object -- ) + "limit" sql% sql% ; + +! GENERIC: sql-subselect db ( object -- ) +! M: db sql-subselectselect ( object -- ) + ! "(select" sql% sql% ")" sql% ; + +GENERIC: sql-table db ( object -- ) +M: db sql-table ( object -- ) + sql% ; + +GENERIC: sql-set db ( object -- ) +M: db sql-set ( object -- ) + "set" "," sql-interleave ; + +GENERIC: sql-values db ( object -- ) +M: db sql-values ( object -- ) + "values(" sql% "," (sql-interleave) ")" sql% ; + +GENERIC: sql-count db ( object -- ) +M: db sql-count ( object -- ) + "count" sql-function, ; + +GENERIC: sql-sum db ( object -- ) +M: db sql-sum ( object -- ) + "sum" sql-function, ; + +GENERIC: sql-avg db ( object -- ) +M: db sql-avg ( object -- ) + "avg" sql-function, ; + +GENERIC: sql-min db ( object -- ) +M: db sql-min ( object -- ) + "min" sql-function, ; + +GENERIC: sql-max db ( object -- ) +M: db sql-max ( object -- ) + "max" sql-function, ; + : sql-array% ( array -- ) -B unclip { - { \ create [ "create table" sql% ] } - { \ drop [ "drop table" sql% ] } - { \ insert [ "insert into" sql% ] } - { \ update [ "update" sql% ] } - { \ delete [ "delete" sql% ] } - { \ select [ B "select" sql% "," (sql-interleave) ] } - { \ columns [ "," (sql-interleave) ] } - { \ from [ "from" "," sql-interleave ] } - { \ where [ B "where" 0, sql-where ] } - { \ group-by [ "group by" "," sql-interleave ] } - { \ having [ "having" "," sql-interleave ] } - { \ order-by [ "order by" "," sql-interleave ] } - { \ offset [ "offset" sql% sql% ] } - { \ limit [ "limit" sql% sql% ] } - { \ select [ "(select" sql% sql% ")" sql% ] } - { \ table [ sql% ] } - { \ set [ "set" "," sql-interleave ] } - { \ values [ "values(" sql% "," (sql-interleave) ")" sql% ] } - { \ count [ "count" sql-function, ] } - { \ sum [ "sum" sql-function, ] } - { \ avg [ "avg" sql-function, ] } - { \ min [ "min" sql-function, ] } - { \ max [ "max" sql-function, ] } + { \ create [ sql-create ] } + { \ drop [ sql-drop ] } + { \ insert [ sql-insert ] } + { \ update [ sql-update ] } + { \ delete [ sql-delete ] } + { \ select [ sql-select ] } + { \ columns [ sql-columns ] } + { \ from [ sql-from ] } + { \ where [ sql-where ] } + { \ group-by [ sql-group-by ] } + { \ having [ sql-having ] } + { \ order-by [ sql-order-by ] } + { \ offset [ sql-offset ] } + { \ limit [ sql-limit ] } + { \ table [ sql-table ] } + { \ set [ sql-set ] } + { \ values [ sql-values ] } + { \ count [ sql-count ] } + { \ sum [ sql-sum ] } + { \ avg [ sql-avg ] } + { \ min [ sql-min ] } + { \ max [ sql-max ] } [ sql% [ sql% ] each ] } case ; +*/ +: sql-array% ( array -- ) drop ; ERROR: no-sql-match ; : sql% ( obj -- ) { @@ -74,4 +172,5 @@ ERROR: no-sql-match ; } cond ; : parse-sql ( obj -- sql in-spec out-spec in out ) - [ [ sql% ] each ] { { } { } { } } nmake ; + [ [ sql% ] each ] { { } { } { } } nmake + [ " " join ] 2dip ; diff --git a/basis/db/tuples/tuples-docs.factor b/basis/db/tuples/tuples-docs.factor new file mode 100644 index 0000000000..42e9cdb928 --- /dev/null +++ b/basis/db/tuples/tuples-docs.factor @@ -0,0 +1,191 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: classes help.markup help.syntax io.streams.string kernel +quotations sequences strings multiline math ; +IN: db.tuples + +HELP: define-persistent +{ $values + { "class" class } { "table" string } { "columns" "an array of slot specifiers" } } +{ $description "Defines a relation from a Factor " { $snippet "tuple class" } " to a SQL database table name. The format for the slot specifiers is as follows:" +{ $list + { "a slot name from the " { $snippet "tuple class" } } + { "the name of a database column that maps to the slot" } { "a database type (see " { $link "db.types" } ")" } +} } ; + +HELP: create-table +{ $values + { "class" class } } +{ $description "Creates a SQL table from a mapping defined by " { $link define-persistent } ". If the table already exists, the database will likely throw an error." } ; + +HELP: ensure-table +{ $values + { "class" class } } +{ $description "Creates a SQL table from a mapping defined by " { $link define-persistent } ". If the table already exists, the error is silently ignored." } ; + +HELP: ensure-tables +{ $values + { "classes" null } } +{ $description "Creates a SQL table from a mapping defined by " { $link define-persistent } ". If a table already exists, the error is silently ignored." } ; + +HELP: recreate-table +{ $values + { "class" class } } +{ $description "Drops an existing table and re-creates it from a mapping defined by " { $link define-persistent } ". If the table does not exist the error is silently ignored." } +{ $warning { $emphasis "THIS WORD WILL DELETE YOUR DATA." } $nl +" Use " { $link ensure-table } " unless you want to delete the data in this table." } ; + +{ create-table ensure-table ensure-tables recreate-table } related-words + +HELP: drop-table +{ $values + { "class" class } } +{ $description "Drops an existing table which deletes all of the data. The database will probably throw an error if the table does not exist." } +{ $warning { $emphasis "THIS WORD WILL DELETE YOUR DATA." } } ; + +HELP: insert-tuple +{ $values + { "tuple" tuple } } +{ $description "Inserts a tuple into a database if a relation has been defined with " { $link define-persistent } ". If a mapping states that the database assigns a primary key to the tuple, this value will be set after this word runs." } +{ $notes "Objects should only be inserted into a database once per object. To store the object after the initial insert, call " { $link update-tuple } "." } ; + +HELP: update-tuple +{ $values + { "tuple" tuple } } +{ $description "Updates a tuple that has already been inserted into a database. The tuple must have a primary key that has been set by " { $link insert-tuple } " or that is user-defined." } ; + +HELP: delete-tuples +{ $values + { "tuple" tuple } } +{ $description "Uses the " { $snippet "tuple" } " as an exemplar object and deletes any objects that have the same slots set. If a slot is not " { $link f } ", then it is used to generate a SQL statement that deletes tuples." } +{ $warning "This word will delete your data." } ; + +{ insert-tuple update-tuple delete-tuples } related-words + +HELP: select-tuple +{ $values + { "tuple" tuple } + { "tuple/f" "a tuple or f" } } +{ $description "A SQL query is constructed from the slots of the exemplar tuple that are not " { $link f } ". Returns a single tuple from the database if it matches the query constructed from the exemplar tuple." } ; + +HELP: select-tuples +{ $values + { "tuple" tuple } + { "tuples" "an array of tuples" } } +{ $description "A SQL query is constructed from the slots of the exemplar tuple that are not " { $link f } ". Returns a multiple tuples from the database that match the query constructed from the exemplar tuple." } ; + +HELP: count-tuples +{ $values + { "tuple" tuple } { "groups" "an array of slots to group by" } + { "n" integer } } +{ $description "" } ; + +HELP: query +{ $values + { "tuple" null } { "query" null } + { "tuples" null } } +{ $description "" } ; + +{ select-tuple select-tuples count-tuples query } related-words + +ARTICLE: "db-tuples" "High-level tuple/database integration" +"Start with a tutorial:" +{ $subsection "db-tuples-tutorial" } +"Useful words:" +{ $subsection "db-tuples-words" } + +; + +ARTICLE: "db-tuples-words" "High-level tuple/database words" +"Making tuples work with a database:" +{ $subsection define-persistent } +"Creating tables:" +{ $subsection create-table } +{ $subsection ensure-table } +{ $subsection ensure-tables } +{ $subsection recreate-table } +"Dropping tables:" +{ $subsection drop-table } +"Inserting a tuple:" +{ $subsection insert-tuple } +"Updating a tuple:" +{ $subsection update-tuple } +"Deleting tuples:" +{ $subsection delete-tuples } +"Querying tuples:" +{ $subsection select-tuple } +{ $subsection select-tuples } +{ $subsection count-tuples } +"Advanced querying of tuples:" +{ $subsection query } ; + + +ARTICLE: "db-tuples-protocol" "High-level tuple/database protocol" +; + +ARTICLE: "db-tuples-tutorial" "Tuple database tutorial" +"Let's make a tuple and store it in a database. To follow along, click on each code example and run it in the listener. If you forget to run an example, just start at the top and run them all again in order." $nl +"We're going to store books in this tutorial." +{ $code "TUPLE: book id title author date-published edition cover-price condition ;" } +"The title, author, and publisher should be strings; the date-published a timestamp; the edition an integer; the cover-price a float. These are the Factor types for which we will need to look up the corresponding " { $link "db.types" } ". " $nl +"To actually bind the tuple slots to the database types, we'll use " { $link define-persistent } "." +{ $code +<" USING: db.tuples db.types ; +book "BOOK" +{ + { "id" "ID" +db-assigned-id+ } + { "title" "TITLE" VARCHAR } + { "author" "AUTHOR" VARCHAR } + { "date-published" "DATE_PUBLISHED" TIMESTAMP } + { "edition" "EDITION" INTEGER } + { "cover-price" "COVER_PRICE" DOUBLE } + { "condition" "CONDITION" VARCHAR } +} define-persistent "> } +"That's all we'll have to do with the database for this tutorial. Now let's make a book." +{ $code <" USING: calendar namespaces ; +T{ book + { title "Factor for Sheeple" } + { author "Mister Stacky Pants" } + { date-published T{ timestamp { year 2009 } { month 3 } { day 3 } } } + { edition 1 } + { cover-price 13.37 } +} book set +"> } +"Now we've created a book. Let's save it to the database." +{ $code <" USING: db db.sqlite fry io.files ; +: with-book-tutorial ( quot -- ) + '[ "book-tutorial.db" temp-file sqlite-db , with-db ] call ; + +[ + book recreate-table + book get insert-tuple +] with-book-tutorial +"> } +"Is it really there?" +{ $code <" [ + T{ book { title "Factor for Sheeple" } } select-tuples . +] with-book-tutorial "> } +"Oops, we spilled some orange juice on the book cover." +{ $code <" book get "Small orange juice stain on cover" >>condition "> } +"Now let's save the modified book." +{ $code <" [ + book get update-tuple +] with-book-tutorial "> } +"And select it again. You can query the database by any field -- just set it in the exemplar tuple you pass to " { $link select-tuples } "." +{ $code <" [ + T{ book { title "Factor for Sheeple" } } select-tuples +] with-book-tutorial "> } +"Let's drop the table because we're done." +{ $code <" [ + book drop-table +] with-book-tutorial "> } +"To summarize, the steps for using Factor's tuple database are:" +{ $list + "Make a new tuple to represent your data" + { "Map the Factor types to the database types with " { $link define-persistent } } + { "Make a " { $link "db-custom-database-combinators" } " to open your database and run a " { $snippet "quotation" } } + { "Create a table with " { $link create-table } ", " { $link ensure-table } ", or " { $link recreate-table } } + { "Start making and storing objects with " { $link insert-tuple } ", " { $link update-tuple } ", " { $link delete-tuples } ", and " { $link select-tuples } } +} ; + +ABOUT: "db-tuples" diff --git a/basis/db/tuples/tuples.factor b/basis/db/tuples/tuples.factor index 437224ea5a..9c8f595e68 100755 --- a/basis/db/tuples/tuples.factor +++ b/basis/db/tuples/tuples.factor @@ -49,36 +49,6 @@ HOOK: db ( tuple class groups -- n ) HOOK: insert-tuple* db ( tuple statement -- ) GENERIC: eval-generator ( singleton -- obj ) -SINGLETON: retryable - -: make-retryable ( obj -- obj' ) - dup sequence? [ - [ make-retryable ] map - ] [ - retryable >>type - 10 >>retries - ] if ; - -: regenerate-params ( statement -- statement ) - dup - [ bind-params>> ] [ in-params>> ] bi - [ - dup generator-bind? [ - generator-singleton>> eval-generator >>value - ] [ - drop - ] if - ] 2map >>bind-params ; - -M: retryable execute-statement* ( statement type -- ) - drop [ retries>> ] [ - [ - nip - [ query-results dispose t ] - [ ] - [ regenerate-params bind-statement* f ] cleanup - ] curry - ] bi attempt-all drop ; : resulting-tuple ( class row out-params -- tuple ) rot class new [ @@ -98,9 +68,6 @@ M: retryable execute-statement* ( statement type -- ) >r slot-name>> r> set-slot-named ] curry 2each ; -: sql-props ( class -- columns table ) - [ db-columns ] [ db-table ] bi ; - : with-disposals ( seq quot -- ) over sequence? [ [ with-disposal ] curry each diff --git a/basis/db/types/types-docs.factor b/basis/db/types/types-docs.factor new file mode 100644 index 0000000000..687ce7b991 --- /dev/null +++ b/basis/db/types/types-docs.factor @@ -0,0 +1,303 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: classes hashtables help.markup help.syntax io.streams.string kernel sequences strings ; +IN: db.types + +HELP: (lookup-type) +{ $values + { "obj" object } + { "string" string } } +{ $description "" } ; + +HELP: +autoincrement+ +{ $description "" } ; + +HELP: +db-assigned-id+ +{ $description "" } ; + +HELP: +default+ +{ $description "" } ; + +HELP: +foreign-id+ +{ $description "" } ; + +HELP: +has-many+ +{ $description "" } ; + +HELP: +not-null+ +{ $description "" } ; + +HELP: +null+ +{ $description "" } ; + +HELP: +primary-key+ +{ $description "" } ; + +HELP: +random-id+ +{ $description "" } ; + +HELP: +serial+ +{ $description "" } ; + +HELP: +unique+ +{ $description "" } ; + +HELP: +user-assigned-id+ +{ $description "" } ; + +HELP: +{ $description "" } ; + +HELP: +{ $description "" } ; + +HELP: +{ $description "" } ; + +HELP: BIG-INTEGER +{ $description "" } ; + +HELP: BLOB +{ $description "" } ; + +HELP: BOOLEAN +{ $description "" } ; + +HELP: DATE +{ $description "" } ; + +HELP: DATETIME +{ $description "" } ; + +HELP: DOUBLE +{ $description "" } ; + +HELP: FACTOR-BLOB +{ $description "" } ; + +HELP: INTEGER +{ $description "" } ; + +HELP: NULL +{ $description "" } ; + +HELP: REAL +{ $description "" } ; + +HELP: SIGNED-BIG-INTEGER +{ $description "" } ; + +HELP: TEXT +{ $description "" } ; + +HELP: TIME +{ $description "" } ; + +HELP: TIMESTAMP +{ $description "" } ; + +HELP: UNSIGNED-BIG-INTEGER +{ $description "" } ; + +HELP: URL +{ $description "" } ; + +HELP: VARCHAR +{ $description "" } ; + +HELP: assigned-id-spec? +{ $values + { "spec" null } + { "?" "a boolean" } } +{ $description "" } ; + +HELP: bind# +{ $values + { "spec" null } { "obj" object } } +{ $description "" } ; + +HELP: bind% +{ $values + { "spec" null } } +{ $description "" } ; + +HELP: compound +{ $values + { "string" string } { "obj" object } + { "hash" hashtable } } +{ $description "" } ; + +HELP: db-assigned-id-spec? +{ $values + { "spec" null } + { "?" "a boolean" } } +{ $description "" } ; + +HELP: double-quote +{ $values + { "string" string } + { "new-string" null } } +{ $description "" } ; + +HELP: find-primary-key +{ $values + { "specs" null } + { "obj" object } } +{ $description "" } ; + +HELP: find-random-generator +{ $values + { "seq" sequence } + { "obj" object } } +{ $description "" } ; + +HELP: generator-bind +{ $description "" } ; + +HELP: get-slot-named +{ $values + { "name" null } { "obj" object } + { "value" null } } +{ $description "" } ; + +HELP: join-space +{ $values + { "string1" string } { "string2" string } + { "new-string" null } } +{ $description "" } ; + +HELP: literal-bind +{ $description "" } ; + +HELP: lookup-create-type +{ $values + { "obj" object } + { "string" string } } +{ $description "" } ; + +HELP: lookup-modifier +{ $values + { "obj" object } + { "string" string } } +{ $description "" } ; + +HELP: lookup-type +{ $values + { "obj" object } + { "string" string } } +{ $description "" } ; + +HELP: low-level-binding +{ $description "" } ; + +HELP: modifiers +{ $values + { "spec" null } + { "string" string } } +{ $description "" } ; + +HELP: no-sql-type +{ $description "" } ; + +HELP: normalize-spec +{ $values + { "spec" null } } +{ $description "" } ; + +HELP: number>string* +{ $values + { "n/string" null } + { "string" string } } +{ $description "" } ; + +HELP: offset-of-slot +{ $values + { "string" string } { "obj" object } + { "n" null } } +{ $description "" } ; + +HELP: paren +{ $values + { "string" string } + { "new-string" null } } +{ $description "" } ; + +HELP: persistent-table +{ $values + + { "hash" hashtable } } +{ $description "" } ; + +HELP: primary-key? +{ $values + { "spec" null } + { "?" "a boolean" } } +{ $description "" } ; + +HELP: random-id-generator +{ $description "" } ; + +HELP: relation? +{ $values + { "spec" null } + { "?" "a boolean" } } +{ $description "" } ; + +HELP: remove-db-assigned-id +{ $values + { "specs" null } + { "obj" object } } +{ $description "" } ; + +HELP: remove-id +{ $values + { "specs" null } + { "obj" object } } +{ $description "" } ; + +HELP: remove-relations +{ $values + { "specs" null } + { "newcolumns" null } } +{ $description "" } ; + +HELP: set-slot-named +{ $values + { "value" null } { "name" null } { "obj" object } } +{ $description "" } ; + +HELP: single-quote +{ $values + { "string" string } + { "new-string" null } } +{ $description "" } ; + +HELP: spec>tuple +{ $values + { "class" class } { "spec" null } + { "tuple" null } } +{ $description "" } ; + +HELP: sql-spec +{ $description "" } ; + +HELP: tuple>filled-slots +{ $values + { "tuple" null } + { "alist" "an array of key/value pairs" } } +{ $description "" } ; + +HELP: tuple>params +{ $values + { "specs" null } { "tuple" null } + { "obj" object } } +{ $description "" } ; + +HELP: unknown-modifier +{ $description "" } ; + +ARTICLE: "db.types" "Database types" +"The " { $vocab-link "db.types" } " vocabulary maps Factor types to database types." +; + +ABOUT: "db.types" diff --git a/basis/help/cookbook/cookbook.factor b/basis/help/cookbook/cookbook.factor index 1539a07d68..aef6ce6809 100755 --- a/basis/help/cookbook/cookbook.factor +++ b/basis/help/cookbook/cookbook.factor @@ -182,6 +182,7 @@ $nl ARTICLE: "cookbook-io" "Input and output cookbook" "Ask the user for their age, and print it back:" { $code + "USING: io math.parser ;" ": ask-age ( -- ) \"How old are you?\" print ;" ": read-age ( -- n ) readln string>number ;" ": print-age ( n -- )" @@ -193,22 +194,26 @@ ARTICLE: "cookbook-io" "Input and output cookbook" } "Print the lines of a file in sorted order:" { $code - "utf8 \"lines.txt\" file-lines natural-sort [ print ] each" + "USING: io io.encodings.utf8 io.files sequences sorting ;" + "\"lines.txt\" utf8 file-lines natural-sort [ print ] each" } "Read 1024 bytes from a file:" { $code + "USING: io io.encodings.binary io.files ;" "\"data.bin\" binary [ 1024 read ] with-file-reader" } "Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:" { $code + "USING: accessors grouping io.files io.mmap kernel sequences ;" "\"mydata.dat\" dup file-info size>> [" " 4 [ reverse-here ] change-each" "] with-mapped-file" } "Send some bytes to a remote host:" { $code - "\"myhost\" 1033 " - "[ { 12 17 102 } >string write ] with-client" + "USING: io io.encodings.ascii io.sockets strings ;" + "\"myhost\" 1033 ascii" + "[ B{ 12 17 102 } write ] with-client" } { $references { } @@ -244,7 +249,7 @@ ARTICLE: "cookbook-application" "Application cookbook" } "See " { $link POSTPONE: MAIN: } " for details. The " { $link run } " word loads a vocabulary if necessary, and calls its main entry point; try the following, it's fun:" { $code "\"tetris\" run" } -"On Mac OS X and Windows, stand-alone applications can also be deployed; these are genuine, 100% native code double-clickable executables:" +"Factor can deploy stand-alone executables; they do not have any external dependencies and consist entirely of compiled native machine code:" { $code "\"tetris\" deploy-tool" } { $references { } diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index 34ab1a2fcc..c2fd94e5cf 100755 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -191,7 +191,8 @@ M: wrapper >pprint-sequence wrapped>> 1array ; M: callstack >pprint-sequence callstack>array ; M: tuple >pprint-sequence - [ class f 2array ] [ tuple-slots ] bi append ; + [ class ] [ tuple-slots ] bi + [ 1array ] [ [ f 2array ] dip append ] if-empty ; GENERIC: pprint-narrow? ( obj -- ? ) diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index c4cca565c7..12f9a55795 100644 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -119,7 +119,7 @@ ERROR: no-vocab vocab ; { "assoc3" assoc } { "newassoc" assoc } { "alist" "an array of key/value pairs" } { "keys" sequence } { "values" sequence } - { "class" class } + { "class" class } { "tuple" tuple } } at* ; : add-using ( object -- ) diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index cd0b582cb1..16d16c3e77 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -338,7 +338,7 @@ HELP: if-empty HELP: when-empty { $values { "seq" sequence } { "quot" "the first quotation of an " { $link if-empty } } } -{ $description "Makes an implicit check if the sequence is empty. An empty sequence is dropped and the " { $snippet "quot1" } " is called." } +{ $description "Makes an implicit check if the sequence is empty. An empty sequence is dropped and the " { $snippet "quot" } " is called." } { $examples "This word is equivalent to " { $link if-empty } " with an empty second quotation:" { $example "USING: sequences prettyprint ;" @@ -355,7 +355,7 @@ HELP: when-empty HELP: unless-empty { $values { "seq" sequence } { "quot" "the second quotation of an " { $link if-empty } } } -{ $description "Makes an implicit check if the sequence is empty. An empty sequence is dropped. Otherwise, the " { $snippet "quot2" } " is called on the sequence." } +{ $description "Makes an implicit check if the sequence is empty. An empty sequence is dropped. Otherwise, the " { $snippet "quot" } " is called on the sequence." } { $examples "This word is equivalent to " { $link if-empty } " with an empty first quotation:" { $example "USING: sequences prettyprint ;" diff --git a/extra/project-euler/001/001.factor b/extra/project-euler/001/001.factor index 843f8b87ba..344b0f1209 100644 --- a/extra/project-euler/001/001.factor +++ b/extra/project-euler/001/001.factor @@ -19,8 +19,17 @@ IN: project-euler.001 ! Inclusion-exclusion principle + + : euler001 ( -- answer ) - 0 999 3 sum 0 999 5 sum + 0 999 15 sum - ; + 999 3 sum-divisible-by + 999 5 sum-divisible-by + + 999 15 sum-divisible-by - ; ! [ euler001 ] 100 ave-time ! 0 ms run / 0 ms GC ave time - 100 trials @@ -30,9 +39,16 @@ IN: project-euler.001 ! ------------------- : euler001a ( -- answer ) - 1000 [ dup 5 mod swap 3 mod [ zero? ] either? ] filter sum ; + 0 999 3 sum 0 999 5 sum + 0 999 15 sum - ; ! [ euler001a ] 100 ave-time ! 0 ms run / 0 ms GC ave time - 100 trials + +: euler001b ( -- answer ) + 1000 [ dup 5 mod swap 3 mod [ zero? ] either? ] filter sum ; + +! [ euler001b ] 100 ave-time +! 0 ms run / 0 ms GC ave time - 100 trials + MAIN: euler001 diff --git a/extra/project-euler/014/014.factor b/extra/project-euler/014/014.factor index b99e34d36f..4f17e855b7 100644 --- a/extra/project-euler/014/014.factor +++ b/extra/project-euler/014/014.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2007 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays combinators.lib kernel math math.ranges namespaces sequences - sorting combinators.short-circuit ; +USING: arrays combinators.lib combinators.short-circuit kernel math math.ranges + namespaces sequences sorting ; IN: project-euler.014 ! http://projecteuler.net/index.php?section=problems&id=14 diff --git a/extra/project-euler/021/021.factor b/extra/project-euler/021/021.factor index f09b0c0b42..9ae5f6af10 100644 --- a/extra/project-euler/021/021.factor +++ b/extra/project-euler/021/021.factor @@ -1,8 +1,7 @@ ! Copyright (c) 2007 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators.lib kernel math math.functions math.ranges namespaces - project-euler.common sequences sequences.lib - combinators.short-circuit ; +USING: combinators.lib combinators.short-circuit kernel math math.functions + math.ranges namespaces project-euler.common sequences sequences.lib ; IN: project-euler.021 ! http://projecteuler.net/index.php?section=problems&id=21 diff --git a/extra/project-euler/036/036.factor b/extra/project-euler/036/036.factor index 4a4f906467..f3a9f738bf 100644 --- a/extra/project-euler/036/036.factor +++ b/extra/project-euler/036/036.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators.lib kernel math.parser math.ranges project-euler.common - sequences combinators.short-circuit ; +USING: combinators.lib combinators.short-circuit kernel math.parser math.ranges + project-euler.common sequences ; IN: project-euler.036 ! http://projecteuler.net/index.php?section=problems&id=36 diff --git a/extra/project-euler/043/043.factor b/extra/project-euler/043/043.factor index e095d94ead..a2f4ad5c61 100644 --- a/extra/project-euler/043/043.factor +++ b/extra/project-euler/043/043.factor @@ -1,8 +1,8 @@ ! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators.lib hashtables kernel math math.combinatorics math.parser - math.ranges project-euler.common sequences sequences.lib sorting - sets combinators.short-circuit ; +USING: combinators.lib combinators.short-circuit hashtables kernel math + math.combinatorics math.parser math.ranges project-euler.common sequences + sequences.lib sorting sets ; IN: project-euler.043 ! http://projecteuler.net/index.php?section=problems&id=43 diff --git a/extra/project-euler/052/052.factor b/extra/project-euler/052/052.factor index 194530ea78..aec8015f94 100644 --- a/extra/project-euler/052/052.factor +++ b/extra/project-euler/052/052.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators.lib kernel math project-euler.common sequences -sorting combinators.short-circuit ; +USING: combinators.lib combinators.short-circuit kernel math + project-euler.common sequences sorting ; IN: project-euler.052 ! http://projecteuler.net/index.php?section=problems&id=52 diff --git a/extra/project-euler/076/076.factor b/extra/project-euler/076/076.factor index 782d6d0429..3530f2163a 100644 --- a/extra/project-euler/076/076.factor +++ b/extra/project-euler/076/076.factor @@ -1,7 +1,7 @@ -! Copyright (c) 2008 Eric Mertens +! Copyright (c) 2008 Eric Mertens. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs combinators kernel math sequences -math.order math.ranges locals ; +USING: arrays assocs combinators kernel locals math math.order math.ranges + sequences ; IN: project-euler.076 ! http://projecteuler.net/index.php?section=problems&id=76 @@ -12,6 +12,7 @@ IN: project-euler.076 ! How many different ways can one hundred be written as a ! sum of at least two positive integers? + ! SOLUTION ! -------- @@ -43,12 +44,17 @@ IN: project-euler.076 :: each-subproblem ( n quot -- ) n [1,b] [ dup [1,b] quot with each ] each ; inline -PRIVATE> - : (euler076) ( n -- m ) dup init [ [ ways ] curry each-subproblem ] [ [ dup 2array ] dip at 1- ] 2bi ; -: euler076 ( -- m ) +PRIVATE> + +: euler076 ( -- answer ) 100 (euler076) ; + +! [ euler076 ] 100 ave-time +! 704 ms run time - 100 trials + +MAIN: euler076 diff --git a/extra/project-euler/100/100.factor b/extra/project-euler/100/100.factor index d2d396a0e1..fca1bf8af8 100644 --- a/extra/project-euler/100/100.factor +++ b/extra/project-euler/100/100.factor @@ -1,7 +1,36 @@ -USING: kernel sequences math.functions math ; +! Copyright (c) 2008 Eric Mertens. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.functions sequences ; IN: project-euler.100 -: euler100 ( -- n ) +! http://projecteuler.net/index.php?section=problems&id=100 + +! DESCRIPTION +! ----------- + +! If a box contains twenty-one coloured discs, composed of fifteen blue discs +! and six red discs, and two discs were taken at random, it can be seen that +! the probability of taking two blue discs, P(BB) = (15/21)*(14/20) = 1/2. + +! The next such arrangement, for which there is exactly 50% chance of taking +! two blue discs at random, is a box containing eighty-five blue discs and +! thirty-five red discs. + +! By finding the first arrangement to contain over 10^12 = 1,000,000,000,000 +! discs in total, determine the number of blue discs that the box would contain. + + +! SOLUTION +! -------- + +: euler100 ( -- answer ) 1 1 [ dup dup 1- * 2 * 10 24 ^ <= ] [ tuck 6 * swap - 2 - ] [ ] while nip ; + +! TODO: solution is incredibly slow (>30 minutes) and needs generalization + +! [ euler100 ] time +! ? ms run time + +MAIN: euler100 diff --git a/extra/project-euler/116/116.factor b/extra/project-euler/116/116.factor index d48cdf175c..5e2059ad9a 100644 --- a/extra/project-euler/116/116.factor +++ b/extra/project-euler/116/116.factor @@ -1,7 +1,6 @@ -! Copyright (c) 2008 Eric Mertens +! Copyright (c) 2008 Eric Mertens. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math math.ranges sequences sequences.lib ; - IN: project-euler.116 ! http://projecteuler.net/index.php?section=problems&id=116 @@ -24,6 +23,7 @@ IN: project-euler.116 ! length be replaced if colours cannot be mixed and at least one coloured tile ! must be used? + ! SOLUTION ! -------- @@ -46,10 +46,15 @@ IN: project-euler.116 : ways ( length colortile -- permutations ) V{ 1 } clone [ [ next ] 2curry times ] keep peek 1- ; -PRIVATE> - : (euler116) ( length -- permutations ) 3 [1,b] [ ways ] with sigma ; -: euler116 ( -- permutations ) +PRIVATE> + +: euler116 ( -- answer ) 50 (euler116) ; + +! [ euler116 ] 100 ave-time +! 0 ms run time - 100 trials + +MAIN: euler116 diff --git a/extra/project-euler/117/117.factor b/extra/project-euler/117/117.factor index 3a05261710..cc5dea8f37 100644 --- a/extra/project-euler/117/117.factor +++ b/extra/project-euler/117/117.factor @@ -1,7 +1,6 @@ -! Copyright (c) 2008 Eric Mertens +! Copyright (c) 2008 Eric Mertens. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.order splitting sequences ; - +USING: kernel math math.order sequences splitting ; IN: project-euler.117 ! http://projecteuler.net/index.php?section=problems&id=117 @@ -14,7 +13,8 @@ IN: project-euler.117 ! units, and blue tiles measuring four units, it is possible to tile a ! row measuring five units in length in exactly fifteen different ways. -! How many ways can a row measuring fifty units in length be tiled? +! How many ways can a row measuring fifty units in length be tiled? + ! SOLUTION ! -------- @@ -33,10 +33,15 @@ IN: project-euler.117 : next ( seq -- ) [ 4 short tail* sum ] keep push ; -PRIVATE> - : (euler117) ( n -- m ) V{ 1 } clone tuck [ next ] curry times peek ; -: euler117 ( -- m ) +PRIVATE> + +: euler117 ( -- answer ) 50 (euler117) ; + +! [ euler117 ] 100 ave-time +! 0 ms run time - 100 trials + +MAIN: euler117 diff --git a/extra/project-euler/148/148.factor b/extra/project-euler/148/148.factor index ead9a4e58d..49fd9a4895 100644 --- a/extra/project-euler/148/148.factor +++ b/extra/project-euler/148/148.factor @@ -1,9 +1,34 @@ -! Copyright (c) 2008 Eric Mertens +! Copyright (c) 2008 Eric Mertens. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math math.functions sequences sequences.lib ; - IN: project-euler.148 +! http://projecteuler.net/index.php?section=problems&id=148 + +! DESCRIPTION +! ----------- + +! We can easily verify that none of the entries in the first seven rows of +! Pascal's triangle are divisible by 7: + +! 1 +! 1 1 +! 1 2 1 +! 1 3 3 1 +! 1 4 6 4 1 +! 1 5 10 10 5 1 +! 1 6 15 20 15 6 1 + +! However, if we check the first one hundred rows, we will find that only 2361 +! of the 5050 entries are not divisible by 7. + +! Find the number of entries which are not divisible by 7 in the first one +! billion (10^9) rows of Pascal's triangle. + + +! SOLUTION +! -------- + - : (euler148) ( x -- y ) >base7 0 [ (use-digit) ] reduce-index ; -: euler148 ( -- y ) +PRIVATE> + +: euler148 ( -- answer ) 10 9 ^ (euler148) ; + +! [ euler148 ] 100 ave-time +! 0 ms run time - 100 trials + +MAIN: euler148 diff --git a/extra/project-euler/150/150.factor b/extra/project-euler/150/150.factor index 49de5dbc03..c7d878edcb 100644 --- a/extra/project-euler/150/150.factor +++ b/extra/project-euler/150/150.factor @@ -1,9 +1,33 @@ -! Copyright (c) 2008 Eric Mertens +! Copyright (c) 2008 Eric Mertens. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.order sequences sequences.private -locals hints ; +USING: hints kernel locals math math.order sequences sequences.private ; IN: project-euler.150 +! http://projecteuler.net/index.php?section=problems&id=150 + +! DESCRIPTION +! ----------- + +! In a triangular array of positive and negative integers, we wish to find a +! sub-triangle such that the sum of the numbers it contains is the smallest +! possible. + +! In the example below, it can be easily verified that the marked triangle +! satisfies this condition having a sum of -42. + +! We wish to make such a triangular array with one thousand rows, so we +! generate 500500 pseudo-random numbers sk in the range +/-2^19, using a type of +! random number generator (known as a Linear Congruential Generator) as +! follows: + +! ... + +! Find the smallest possible sub-triangle sum. + + +! SOLUTION +! -------- + + 0 1000 [ 1+ [ next ] replicate partial-sums ] map nip ; :: (euler150) ( m -- n ) [let | table [ sums-triangle ] | @@ -46,5 +67,12 @@ PRIVATE> HINTS: (euler150) fixnum ; -: euler150 ( -- n ) +PRIVATE> + +: euler150 ( -- answer ) 1000 (euler150) ; + +! [ euler150 ] 10 ave-time +! 32858 ms run time - 10 trials + +MAIN: euler150 diff --git a/extra/project-euler/151/151.factor b/extra/project-euler/151/151.factor index b2bbbcc0da..b64ae3d49f 100644 --- a/extra/project-euler/151/151.factor +++ b/extra/project-euler/151/151.factor @@ -1,9 +1,41 @@ -! Copyright (c) 2008 Eric Mertens +! Copyright (c) 2008 Eric Mertens. ! See http://factorcode.org/license.txt for BSD license. -USING: sequences combinators kernel sequences.lib math math.order -assocs namespaces ; +USING: assocs combinators kernel math math.order namespaces sequences + sequences.lib ; IN: project-euler.151 +! http://projecteuler.net/index.php?section=problems&id=151 + +! DESCRIPTION +! ----------- + +! A printing shop runs 16 batches (jobs) every week and each batch requires a +! sheet of special colour-proofing paper of size A5. + +! Every Monday morning, the foreman opens a new envelope, containing a large +! sheet of the special paper with size A1. + +! He proceeds to cut it in half, thus getting two sheets of size A2. Then he +! cuts one of them in half to get two sheets of size A3 and so on until he +! obtains the A5-size sheet needed for the first batch of the week. + +! All the unused sheets are placed back in the envelope. + +! At the beginning of each subsequent batch, he takes from the envelope one +! sheet of paper at random. If it is of size A5, he uses it. If it is larger, +! he repeats the 'cut-in-half' procedure until he has what he needs and any +! remaining sheets are always placed back in the envelope. + +! Excluding the first and last batch of the week, find the expected number of +! times (during each week) that the foreman finds a single sheet of paper in +! the envelope. + +! Give your answer rounded to six decimal places using the format x.xxxxxx . + + +! SOLUTION +! -------- + SYMBOL: table : (pick-sheet) ( seq i -- newseq ) @@ -34,8 +66,15 @@ DEFER: (euler151) [ [ dup length [ pick-sheet ] with map sum ] [ sum ] bi / ] } case ] cache ; -: euler151 ( -- n ) +: euler151 ( -- answer ) [ H{ } clone table set { 1 1 1 1 } (euler151) ] with-scope ; + +! TODO: doesn't work currently, problem in area of 'with map' in (euler151) + +! [ euler151 ] 100 ave-time +! ? ms run time - 100 trials + +MAIN: euler151 diff --git a/extra/project-euler/164/164.factor b/extra/project-euler/164/164.factor index bf1f5dcf9b..9d88e49e0e 100644 --- a/extra/project-euler/164/164.factor +++ b/extra/project-euler/164/164.factor @@ -1,7 +1,6 @@ -! Copyright (c) 2008 Eric Mertens +! Copyright (c) 2008 Eric Mertens. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs kernel math math.ranges sequences ; - IN: project-euler.164 ! http://projecteuler.net/index.php?section=problems&id=164 @@ -12,6 +11,7 @@ IN: project-euler.164 ! How many 20 digit numbers n (without any leading zero) exist such ! that no three consecutive digits of n have a sum greater than 9? + ! SOLUTION ! -------- @@ -29,5 +29,10 @@ IN: project-euler.164 PRIVATE> -: euler164 ( -- n ) +: euler164 ( -- answer ) init-table 19 [ next-table ] times values sum ; + +! [ euler164 ] 100 ave-time +! 8 ms run time - 100 trials + +MAIN: euler164 diff --git a/extra/project-euler/190/190.factor b/extra/project-euler/190/190.factor index 6fc15c9f30..35b9344362 100644 --- a/extra/project-euler/190/190.factor +++ b/extra/project-euler/190/190.factor @@ -1,13 +1,13 @@ -! Copyright (c) 2008 Eric Mertens +! Copyright (c) 2008 Eric Mertens. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences sequences.lib math math.functions math.ranges locals ; IN: project-euler.190 -! PROBLEM -! ------- - ! http://projecteuler.net/index.php?section=problems&id=190 +! DESCRIPTION +! ----------- + ! Let Sm = (x1, x2, ... , xm) be the m-tuple of positive real numbers ! with x1 + x2 + ... + xm = m for which Pm = x1 * x22 * ... * xmm is ! maximised. @@ -17,6 +17,7 @@ IN: project-euler.190 ! Find Σ[Pm] for 2 ≤ m ≤ 15. + ! SOLUTION ! -------- @@ -44,5 +45,10 @@ PRIVATE> :: P_m ( m -- P_m ) m [1,b] [| i | 2 i * m 1+ / i ^ ] PI ; -: euler190 ( -- n ) +: euler190 ( -- answer ) 2 15 [a,b] [ P_m truncate ] sigma ; + +! [ euler150 ] 100 ave-time +! 7 ms run time - 100 trials + +MAIN: euler190 diff --git a/extra/project-euler/ave-time/ave-time-docs.factor b/extra/project-euler/ave-time/ave-time-docs.factor index d8ee0846b0..f2d6b89afc 100644 --- a/extra/project-euler/ave-time/ave-time-docs.factor +++ b/extra/project-euler/ave-time/ave-time-docs.factor @@ -1,22 +1,31 @@ -USING: arrays help.markup help.syntax math memory quotations sequences system tools.time ; +USING: arrays help.markup help.syntax math math.parser memory quotations + sequences system tools.time ; IN: project-euler.ave-time HELP: collect-benchmarks { $values { "quot" quotation } { "n" integer } { "seq" sequence } } -{ $description "Runs a quotation " { $snippet "n" } " times, collecting the wall clock time and the time spent in the garbage collector into pairs inside of a sequence." } -{ $notes "The stack effect of " { $snippet "quot" } " is inferred and only one set of outputs will remain on the stack no matter how many trials are run." +{ $description "Runs a quotation " { $snippet "n" } " times, collecting the wall clock time inside of a sequence." } +{ $notes "The stack effect of " { $snippet "quot" } " is accounted for and only one set of outputs will remain on the stack no matter how many trials are run." $nl "A nicer word for interactive use is " { $link ave-time } "." } ; +HELP: nth-place +{ $values { "x" float } { "n" integer } { "y" float } } +{ $description "Rounds a floating point number to " { $snippet "n" } " decimal places." } +{ $examples + "This word is useful for display purposes when showing 15 decimal places is not desired:" + { $unchecked-example "3.141592653589793 3 nth-place number>string" "\"3.142\"" } +} ; + HELP: ave-time { $values { "quot" quotation } { "n" integer } } -{ $description "Runs a quotation " { $snippet "n" } " times, then prints the average run time and the average time spent in the garbage collector." } -{ $notes "The stack effect of " { $snippet "quot" } " is inferred and only one set of outputs will remain on the stack no matter how many trials are run." } +{ $description "Runs a quotation " { $snippet "n" } " times, then prints the average run time and standard deviation." } +{ $notes "The stack effect of " { $snippet "quot" } " is accounted for and only one set of outputs will remain on the stack no matter how many trials are run." } { $examples "This word can be used to compare performance of the non-optimizing and optimizing compilers." $nl "First, we time a quotation directly; quotations are compiled by the non-optimizing quotation compiler:" - { $unchecked-example "[ 1000000 0 [ + ] reduce drop ] 10 ave-time" "1116 ms run time - 10 trials" } - "Now we define a word and compile it with the optimizing word compiler. This results is faster execution:" - { $unchecked-example ": foo 1000000 0 [ + ] reduce ;" "\\ foo compile" "[ foo drop ] 10 ave-time" "202 ms run time - 10 trials" } + { $unchecked-example "[ 1000000 0 [ + ] reduce drop ] 10 ave-time" "465 ms ave run time - 13.37 SD (10 trials)" } + "Now we define a word and compile it with the optimizing word compiler. This results in faster execution:" + { $unchecked-example ": foo 1000000 0 [ + ] reduce ;" "\\ foo compile" "[ foo drop ] 10 ave-time" "202 ms ave run time - 22.73 SD (10 trials)" } } ; diff --git a/extra/project-euler/ave-time/ave-time.factor b/extra/project-euler/ave-time/ave-time.factor index 56f7185095..be39b26a97 100644 --- a/extra/project-euler/ave-time/ave-time.factor +++ b/extra/project-euler/ave-time/ave-time.factor @@ -1,7 +1,7 @@ -! Copyright (c) 2007 Aaron Schaefer +! Copyright (c) 2007 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays combinators io kernel math math.functions math.parser - math.statistics namespaces sequences tools.time continuations ; +USING: continuations io kernel math math.functions math.parser math.statistics + namespaces tools.time ; IN: project-euler.ave-time : collect-benchmarks ( quot n -- seq ) @@ -10,7 +10,11 @@ IN: project-euler.ave-time [ with-datastack drop ] 2curry r> swap times call ] { } make ; +: nth-place ( x n -- y ) + 10 swap ^ [ * round ] keep / ; + : ave-time ( quot n -- ) - [ collect-benchmarks ] keep swap mean round [ - # " ms run time - " % # " trials" % + [ collect-benchmarks ] keep + swap [ std 2 nth-place ] [ mean round ] bi [ + # " ms ave run time - " % # " SD (" % # " trials)" % ] "" make print flush ; inline diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 3101c900e3..9dfaad0e7b 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -16,8 +16,10 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time project-euler.045 project-euler.046 project-euler.047 project-euler.048 project-euler.052 project-euler.053 project-euler.056 project-euler.059 project-euler.067 project-euler.075 project-euler.079 project-euler.092 - project-euler.097 project-euler.134 project-euler.169 project-euler.173 - project-euler.175 combinators.short-circuit ; + project-euler.097 project-euler.100 project-euler.116 project-euler.117 + project-euler.134 project-euler.148 project-euler.150 project-euler.151 + project-euler.164 project-euler.169 project-euler.173 project-euler.175 + project-euler.186 project-euler.190 ; IN: project-euler