diff --git a/core/compiler/errors/errors.factor b/core/compiler/errors/errors.factor index 65de89524a..363c13c478 100755 --- a/core/compiler/errors/errors.factor +++ b/core/compiler/errors/errors.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces assocs prettyprint io sequences -sorting continuations debugger math ; +sorting continuations debugger math math.parser ; IN: compiler.errors SYMBOL: compiler-errors @@ -41,8 +41,9 @@ M: object compiler-warning? drop f ; : (compiler-report) ( what assoc -- ) length dup zero? [ 2drop ] [ - ":" write over write " - print " write pprint - " compiler " write write "." print + [ + ":" % over % " - print " % # " compiler " % % "." % + ] "" make print ] if ; : compiler-report ( -- ) diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor index b71982f1f2..0181514ab4 100644 --- a/extra/assocs/lib/lib.factor +++ b/extra/assocs/lib/lib.factor @@ -18,7 +18,7 @@ IN: assocs.lib ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : set-hash-stack ( value key seq -- ) - dupd [ key? ] curry* find-last nip set-at ; + dupd [ key? ] when find-last nip set-at ; : at-default ( key assoc -- value/key ) dupd at [ nip ] when* ; diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index 8c5f658523..9a54608126 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -4,7 +4,7 @@ USING: arrays hashtables io io.streams.string kernel math math.vectors math.functions math.parser namespaces sequences strings tuples system debugger combinators vocabs.loader -calendar.backend structs alien.c-types unix ; +calendar.backend structs alien.c-types ; IN: calendar TUPLE: timestamp year month day hour minute second gmt-offset ; @@ -158,7 +158,7 @@ M: integer +minute ( timestamp n -- timestamp ) over timestamp-minute + 60 /rem pick set-timestamp-minute +hour ; M: real +minute ( timestamp n -- timestamp ) - float>whole-part rot swap 60 * +second swap +minute ; + float>whole-part rot swap 60 * +second swap +minute ; M: number +second ( timestamp n -- timestamp ) over timestamp-second + 60 /rem >r >bignum r> @@ -217,32 +217,22 @@ M: timestamp <=> ( ts1 ts2 -- n ) 1970 1 1 0 0 0 0 ; : unix-time>timestamp ( n -- timestamp ) - >r unix-1970 r> seconds +dt ; + >r unix-1970 r> seconds +dt ; : timestamp>unix-time ( timestamp -- n ) unix-1970 timestamp- >bignum ; -: timestamp>timeval ( timestamp -- timeval ) - timestamp>unix-time 1000 * make-timeval ; +: timestamp>timeval ( timestamp -- timeval ) + timestamp>unix-time 1000 * make-timeval ; -: timeval>timestamp ( timeval -- timestamp ) +: timeval>timestamp ( timeval -- timestamp ) [ timeval-sec ] keep - timeval-usec 1000000 / + unix-time>timestamp ; - -: timestamp>timespec ( timestamp -- timespec ) - timestamp>unix-time "timespec" - [ set-timespec-sec ] keep ; - -: timespec>timestamp ( timespec -- timestamp ) - [ timespec-sec ] keep - timespec-nsec 1000000000 / + - unix-time>timestamp ; - + timeval-usec 1000000 / + unix-time>timestamp ; : gmt ( -- timestamp ) #! GMT time, right now - unix-1970 millis 1000 /f seconds +dt ; + unix-1970 millis 1000 /f seconds +dt ; : now ( -- timestamp ) gmt >local-time ; : before ( dt -- -dt ) tuple-slots [ neg ] map array>dt ; @@ -278,7 +268,7 @@ M: timestamp <=> ( ts1 ts2 -- n ) [ timestamp-year leap-year? ] keep [ >date< 3array ] keep timestamp-year 3 1 3array <=> 0 >= and 1 0 ? - ] keep + ] keep [ timestamp-month day-counts swap head-slice sum + ] keep timestamp-day + ; @@ -370,35 +360,18 @@ M: timestamp <=> ( ts1 ts2 -- n ) : day-offset ( timestamp m -- timestamp n ) over day-of-week - ; inline - + : day-this-week ( timestamp n -- timestamp ) day-offset days +dt ; - + : sunday ( timestamp -- timestamp ) 0 day-this-week ; : monday ( timestamp -- timestamp ) 1 day-this-week ; : tuesday ( timestamp -- timestamp ) 2 day-this-week ; : wednesday ( timestamp -- timestamp ) 3 day-this-week ; : thursday ( timestamp -- timestamp ) 4 day-this-week ; -: friday ( timestamp -- timestamp ) 5 day-this-week ; +: friday ( timestamp -- timestamp ) 5 day-this-week ; : saturday ( timestamp -- timestamp ) 6 day-this-week ; -: beginning-of-day ( timestamp -- new-timestamp ) - clone dup >r 0 0 0 r> - { set-timestamp-hour set-timestamp-minute set-timestamp-second } - set-slots ; inline - -: beginning-of-month ( timestamp -- new-timestamp ) - clone dup beginning-of-day dup >r 1 r> { set-timestamp-day } set-slots ; - -: beginning-of-week ( timestamp -- new-timestamp ) - clone dup sunday beginning-of-day ; - -: beginning-of-year ( timestamp -- new-timestamp ) - clone dup beginning-of-month dup >r 1 r> { set-timestamp-month } set-slots ; - -: seconds-since-midnight ( timestamp -- x ) - dup beginning-of-day timestamp- ; - { { [ unix? ] [ "calendar.unix" ] } { [ windows? ] [ "calendar.windows" ] } diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor index 1e9b769823..bc0d01956f 100644 --- a/extra/concurrency/concurrency.factor +++ b/extra/concurrency/concurrency.factor @@ -239,7 +239,7 @@ PRIVATE> [ (spawn-server) "Exiting process: " write self process-pid print - ] curry spawn ; + ] curry spawn ; inline : spawn-linked-server ( quot -- process ) #! Similar to 'spawn-server' but the parent process will be linked @@ -247,7 +247,7 @@ PRIVATE> [ (spawn-server) "Exiting process: " write self process-pid print - ] curry spawn-link ; + ] curry spawn-link ; inline : server-cc ( -- cc|process ) #! Captures the current continuation and returns the value. diff --git a/extra/const/const.factor b/extra/const/const.factor index 589f5f7fc0..59d65edaae 100644 --- a/extra/const/const.factor +++ b/extra/const/const.factor @@ -2,7 +2,7 @@ USING: kernel parser words sequences ; IN: const : define-const ( word value -- ) - [ parsed ] curry dupd define-compound + [ parsed ] curry dupd define t "parsing" set-word-prop ; : CONST: diff --git a/extra/crypto/common/common-docs.factor b/extra/crypto/common/common-docs.factor index 1292e04777..032e174eb1 100644 --- a/extra/crypto/common/common-docs.factor +++ b/extra/crypto/common/common-docs.factor @@ -1,5 +1,6 @@ USING: help.markup help.syntax kernel math sequences quotations -crypto.common math.private ; +math.private ; +IN: crypto.common HELP: >32-bit { $values { "x" "an integer" } { "y" "an integer" } } diff --git a/extra/freetype/freetype.factor b/extra/freetype/freetype.factor index e32f14432b..00f7de1370 100755 --- a/extra/freetype/freetype.factor +++ b/extra/freetype/freetype.factor @@ -50,11 +50,11 @@ C-STRUCT: glyph { "FT_Pos" "width" } { "FT_Pos" "height" } - + { "FT_Pos" "hori-bearing-x" } { "FT_Pos" "hori-bearing-y" } { "FT_Pos" "hori-advance" } - + { "FT_Pos" "vert-bearing-x" } { "FT_Pos" "vert-bearing-y" } { "FT_Pos" "vert-advance" } @@ -63,9 +63,9 @@ C-STRUCT: glyph { "FT_Fixed" "linear-vert-advance" } { "FT_Pos" "advance-x" } { "FT_Pos" "advance-y" } - + { "long" "format" } - + { "int" "bitmap-rows" } { "int" "bitmap-width" } { "int" "bitmap-pitch" } @@ -86,16 +86,16 @@ C-STRUCT: glyph { "short*" "contours" } { "int" "outline-flags" } - + { "FT_UInt" "num_subglyphs" } { "void*" "subglyphs" } - + { "void*" "control-data" } { "long" "control-len" } - + { "FT_Pos" "lsb-delta" } { "FT_Pos" "rsb-delta" } - + { "void*" "other" } ; C-STRUCT: face-size @@ -105,10 +105,10 @@ C-STRUCT: face-size { "FT_UShort" "x-ppem" } { "FT_UShort" "y-ppem" } - + { "FT_Fixed" "x-scale" } { "FT_Fixed" "y-scale" } - + { "FT_Pos" "ascender" } { "FT_Pos" "descender" } { "FT_Pos" "height" } @@ -117,46 +117,48 @@ C-STRUCT: face-size C-STRUCT: face { "FT_Long" "num-faces" } { "FT_Long" "index" } - + { "FT_Long" "flags" } { "FT_Long" "style-flags" } - + { "FT_Long" "num-glyphs" } - + { "FT_Char*" "family-name" } { "FT_Char*" "style-name" } - + { "FT_Int" "num-fixed-sizes" } { "void*" "available-sizes" } - + { "FT_Int" "num-charmaps" } { "void*" "charmaps" } - + { "void*" "generic" } { "void*" "generic" } - + { "FT_Pos" "x-min" } { "FT_Pos" "y-min" } { "FT_Pos" "x-max" } { "FT_Pos" "y-max" } - + { "FT_UShort" "units-per-em" } { "FT_Short" "ascender" } { "FT_Short" "descender" } { "FT_Short" "height" } - + { "FT_Short" "max-advance-width" } { "FT_Short" "max-advance-height" } - + { "FT_Short" "underline-position" } { "FT_Short" "underline-thickness" } - + { "glyph*" "glyph" } { "face-size*" "size" } { "void*" "charmap" } ; FUNCTION: FT_Error FT_New_Face ( void* library, FT_Char* font, FT_Long index, face* face ) ; +FUNCTION: FT_Error FT_New_Memory_Face ( void* library, FT_Byte* file_base, FT_Long file_size, FT_Long face_index, FT_Face* aface ) ; + FUNCTION: FT_Error FT_Set_Char_Size ( face* face, FT_F26Dot6 char_width, FT_F26Dot6 char_height, FT_UInt horizontal_dpi, FT_UInt vertical_dpi ) ; FUNCTION: FT_Error FT_Load_Char ( face* face, FT_ULong charcode, FT_Int32 load_flags ) ; diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index 09c175f94c..80419e9c8d 100644 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -1,11 +1,11 @@ -! Copyright (C) 2006 Slava Pestov, Doug Coleman +! Copyright (C) 2006, 2008 Slava Pestov, Doug Coleman ! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs calendar debugger furnace.sessions furnace.validator -hashtables heaps html.elements http http.server.responders -http.server.templating io.files kernel math namespaces -quotations sequences splitting words strings vectors -webapps.callback ; -USING: continuations io prettyprint ; +USING: arrays assocs calendar debugger furnace.sessions +furnace.validator hashtables heaps html.elements http +http.server.responders http.server.templating io.files kernel +math namespaces quotations sequences splitting words strings +vectors webapps.callback continuations tuples classes vocabs +html io ; IN: furnace : code>quotation ( word/quot -- quot ) @@ -174,7 +174,6 @@ PREDICATE: word action "action" word-prop ; [ service-post ] "post" set ] make-responder ; -USING: classes html tuples vocabs ; : explode-tuple ( tuple -- ) dup tuple-slots swap class "slot-names" word-prop [ set ] 2each ; diff --git a/extra/help/cookbook/cookbook.factor b/extra/help/cookbook/cookbook.factor index fc28cff7fa..5cb168b1fd 100755 --- a/extra/help/cookbook/cookbook.factor +++ b/extra/help/cookbook/cookbook.factor @@ -199,7 +199,7 @@ ARTICLE: "cookbook-io" "I/O cookbook" } "Print the lines of a file in sorted order:" { $code - "\"lines.txt\" lines natural-sort [ print ] each" + "\"lines.txt\" file-lines natural-sort [ print ] each" } "Read 1024 bytes from a file:" { $code diff --git a/extra/help/markup/markup.factor b/extra/help/markup/markup.factor index 5d90fd367c..5f1b027823 100644 --- a/extra/help/markup/markup.factor +++ b/extra/help/markup/markup.factor @@ -44,7 +44,7 @@ M: f print-element drop ; : with-default-style ( quot -- ) default-style get [ last-element off - H{ } swap with-nesting + default-style get swap with-nesting ] with-style ; inline : print-content ( element -- ) diff --git a/extra/html/elements/elements-tests.factor b/extra/html/elements/elements-tests.factor new file mode 100644 index 0000000000..786fe0e68c --- /dev/null +++ b/extra/html/elements/elements-tests.factor @@ -0,0 +1,8 @@ +IN: temporary +USING: tools.test html html.elements io.streams.string ; + +: make-html-string + [ with-html-stream ] string-out ; + +[ "" ] +[ [ ] make-html-string ] unit-test diff --git a/extra/html/elements/elements.factor b/extra/html/elements/elements.factor index e5e2e573be..ff3e7b1283 100644 --- a/extra/html/elements/elements.factor +++ b/extra/html/elements/elements.factor @@ -4,17 +4,17 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io kernel namespaces prettyprint quotations -sequences strings words xml.writer compiler.units ; +sequences strings words xml.writer compiler.units effects ; IN: html.elements ! These words are used to provide a means of writing ! formatted HTML to standard output with a familiar 'html' look -! and feel in the code. +! and feel in the code. ! ! HTML tags can be used in a number of different ways. The highest ! level involves a similar syntax to HTML: -! +! !

"someoutput" write

! !

will output the opening tag and

will output the closing @@ -28,7 +28,7 @@ IN: html.elements ! in that namespace. Before the attribute word should come the ! value of that attribute. ! The finishing word will print out the operning tag including -! attributes. +! attributes. ! Any writes after this will appear after the opening tag. ! ! Values for attributes can be used directly without any stack @@ -57,56 +57,59 @@ SYMBOL: html : print-html ( str -- ) write-html "\n" write-html ; -: html-word ( name def -- ) +: html-word ( name def effect -- ) #! Define 'word creating' word to allow #! dynamically creating words. - [ - >r elements-vocab create r> define - ] with-compilation-unit ; - + >r >r elements-vocab create r> r> define-declared ; + : "<" swap ">" 3append ; +: empty-effect T{ effect f 0 0 } ; + : def-for-html-word- ( name -- ) #! Return the name and code for the patterned #! word. - dup swap [ write-html ] curry html-word ; + dup swap [ write-html ] curry + empty-effect html-word ; : ">" append ; : def-for-html-word-foo> ( name -- ) #! Return the name and code for the foo> patterned #! word. - foo> [ ">" write-html ] html-word ; + foo> [ ">" write-html ] empty-effect html-word ; : [ "" % ] "" make ; : def-for-html-word- ( name -- ) #! Return the name and code for the patterned - #! word. - dup [ write-html ] curry html-word ; + #! word. + dup [ write-html ] curry empty-effect html-word ; : [ "<" % % "/>" % ] "" make ; : def-for-html-word- ( name -- ) #! Return the name and code for the patterned #! word. - dup swap [ write-html ] curry html-word ; + dup swap [ write-html ] curry + empty-effect html-word ; : foo/> "/>" append ; : def-for-html-word-foo/> ( name -- ) #! Return the name and code for the foo/> patterned - #! word. - foo/> [ "/>" write-html ] html-word ; + #! word. + foo/> [ "/>" write-html ] empty-effect html-word ; -: define-closed-html-word ( name -- ) +: define-closed-html-word ( name -- ) #! Given an HTML tag name, define the words for #! that closable HTML tag. dup def-for-html-word- @@ -114,7 +117,7 @@ SYMBOL: html dup def-for-html-word-foo> def-for-html-word- ; -: define-open-html-word ( name -- ) +: define-open-html-word ( name -- ) #! Given an HTML tag name, define the words for #! that open HTML tag. dup def-for-html-word- @@ -125,34 +128,38 @@ SYMBOL: html " " write-html write-html "='" write-html - escape-quoted-string write + escape-quoted-string write-html "'" write-html ; +: attribute-effect T{ effect f { "string" } 0 } ; + : define-attribute-word ( name -- ) dup "=" swap append swap - [ write-attr ] curry html-word ; + [ write-attr ] curry attribute-effect html-word ; -! Define some closed HTML tags [ - "h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9" - "ol" "li" "form" "a" "p" "html" "head" "body" "title" - "b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea" - "script" "div" "span" "select" "option" "style" -] [ define-closed-html-word ] each + ! Define some closed HTML tags + [ + "h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9" + "ol" "li" "form" "a" "p" "html" "head" "body" "title" + "b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea" + "script" "div" "span" "select" "option" "style" + ] [ define-closed-html-word ] each -! Define some open HTML tags -[ - "input" - "br" - "link" - "img" -] [ define-open-html-word ] each + ! Define some open HTML tags + [ + "input" + "br" + "link" + "img" + ] [ define-open-html-word ] each -! Define some attributes -[ - "method" "action" "type" "value" "name" - "size" "href" "class" "border" "rows" "cols" - "id" "onclick" "style" "valign" "accesskey" - "src" "language" "colspan" "onchange" "rel" - "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang" -] [ define-attribute-word ] each + ! Define some attributes + [ + "method" "action" "type" "value" "name" + "size" "href" "class" "border" "rows" "cols" + "id" "onclick" "style" "valign" "accesskey" + "src" "language" "colspan" "onchange" "rel" + "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang" + ] [ define-attribute-word ] each +] with-compilation-unit diff --git a/extra/html/html-tests.factor b/extra/html/html-tests.factor index 798d5563fe..5c33df18b3 100644 --- a/extra/html/html-tests.factor +++ b/extra/html/html-tests.factor @@ -54,10 +54,16 @@ M: funky browser-link-href ] make-html-string ] unit-test -[ "
cdr
" ] +[ "
cdr
" ] [ [ H{ { page-color { 1 0 1 1 } } } [ "cdr" write ] with-nesting ] make-html-string ] unit-test + +[ + "
" +] [ + [ H{ } [ ] with-nesting nl ] make-html-string +] unit-test diff --git a/extra/html/html.factor b/extra/html/html.factor index 391737ca61..f9d5bde5e6 100755 --- a/extra/html/html.factor +++ b/extra/html/html.factor @@ -10,7 +10,19 @@ GENERIC: browser-link-href ( presented -- href ) M: object browser-link-href drop f ; -TUPLE: html-stream ; +TUPLE: html-stream last-div? ; + +! A hack: stream-nl after with-nesting or tabular-output is +! ignored, so that HTML stream output looks like UI pane output +: test-last-div? ( stream -- ? ) + dup html-stream-last-div? + f rot set-html-stream-last-div? ; + +: not-a-div ( stream -- stream ) + dup test-last-div? drop ; inline + +: a-div ( stream -- straem ) + t over set-html-stream-last-div? ; inline : ( stream -- stream ) html-stream construct-delegate ; @@ -94,7 +106,7 @@ TUPLE: html-sub-stream style stream ; TUPLE: html-span-stream ; M: html-span-stream stream-close - end-sub-stream format-html-span ; + end-sub-stream not-a-div format-html-span ; : border-css, ( border -- ) "border: 1px solid #" % hex-color, "; " % ; @@ -109,7 +121,7 @@ M: html-span-stream stream-close page-color [ bg-css, ] apply-style border-color [ border-css, ] apply-style border-width [ padding-css, ] apply-style - wrap-margin [ pre-css, ] apply-style + wrap-margin over at pre-css, ] make-css ; : div-tag ( style quot -- ) @@ -127,7 +139,7 @@ M: html-span-stream stream-close TUPLE: html-block-stream ; M: html-block-stream stream-close ( quot style stream -- ) - end-sub-stream format-html-div ; + end-sub-stream a-div format-html-div ; : border-spacing-css, "padding: " % first2 max 2 /i # "px; " % ; @@ -151,7 +163,7 @@ M: html-stream stream-write1 ( char stream -- ) >r 1string r> stream-write ; M: html-stream stream-write ( str stream -- ) - >r escape-string r> delegate stream-write ; + not-a-div >r escape-string r> delegate stream-write ; M: html-stream make-span-stream ( style stream -- stream' ) html-span-stream ; @@ -164,7 +176,7 @@ M: html-stream make-block-stream ( style stream -- stream' ) html-block-stream ; M: html-stream stream-write-table ( grid style stream -- ) - [ + a-div [ swap [ [
@@ -178,7 +190,7 @@ M: html-stream make-cell-stream ( style stream -- stream' ) (html-sub-stream) ; M: html-stream stream-nl ( stream -- ) - [
] with-stream* ; + dup test-last-div? [ drop ] [ [
] with-stream* ] if ; ! Utilities : with-html-stream ( quot -- ) diff --git a/extra/http/server/responders/responders.factor b/extra/http/server/responders/responders.factor index 2dfbf73004..8dcaa7223d 100644 --- a/extra/http/server/responders/responders.factor +++ b/extra/http/server/responders/responders.factor @@ -124,6 +124,10 @@ SYMBOL: max-post-request : header-param ( key -- value ) "header" get at ; +: host ( -- string ) + #! The host the current responder was called from. + "Host" header-param ":" split1 drop ; + : add-responder ( responder -- ) #! Add a responder object to the list. "responder" over at responders get set-at ; diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 58ef587150..99ed41afa3 100644 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -28,10 +28,6 @@ IN: http.server { "HEAD" "head" } } at "bad" or ; -: host ( -- string ) - #! The host the current responder was called from. - "Host" header-param ":" split1 drop ; - : (handle-request) ( arg cmd -- method path host ) request-method dup "method" set swap prepare-url prepare-header host ; diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/templating.factor index 680f7b73d5..69f8b4e7fd 100755 --- a/extra/http/server/templating/templating.factor +++ b/extra/http/server/templating/templating.factor @@ -77,7 +77,6 @@ DEFER: <% delimiter [ [ "quiet" on - file-vocabs parser-notes off templating-vocab use+ dup source-file file set ! so that reload works properly @@ -85,7 +84,7 @@ DEFER: <% delimiter ?resource-path file-contents [ eval-template ] [ html-error. drop ] recover ] keep - ] with-scope + ] with-file-vocabs ] assert-depth drop ; : run-relative-template-file ( filename -- ) diff --git a/extra/io/server/server-tests.factor b/extra/io/server/server-tests.factor new file mode 100644 index 0000000000..5c37a37380 --- /dev/null +++ b/extra/io/server/server-tests.factor @@ -0,0 +1,4 @@ +IN: temporary +USING: tools.test.inference io.server ; + +{ 1 0 } [ [ ] spawn-server ] unit-test-effect diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index 6389c2c024..0141289c38 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -48,7 +48,7 @@ SYMBOL: log-stream dup log-client [ swap with-stream ] 2curry concurrency:spawn drop ; inline -: accept-loop ( server quot -- ) +: accept-loop ( server quot -- server quot ) [ swap accept with-client ] 2keep accept-loop ; inline : server-loop ( server quot -- ) @@ -62,6 +62,7 @@ SYMBOL: log-stream ] [ "Cannot spawn server: " print print-error + 2drop ] recover ; inline : local-server ( port -- seq ) diff --git a/extra/io/windows/ce/ce.factor b/extra/io/windows/ce/ce.factor index ac5066e7ae..9fb0d700d9 100755 --- a/extra/io/windows/ce/ce.factor +++ b/extra/io/windows/ce/ce.factor @@ -1,6 +1,6 @@ USING: io.backend io.windows io.windows.ce.backend io.windows.ce.files io.windows.ce.sockets io.windows.ce.launcher -namespaces ; +namespaces io.windows.mmap ; IN: io.windows.ce T{ windows-ce-io } io-backend set-global diff --git a/extra/math/text/authors.txt b/extra/math/text/english/authors.txt similarity index 100% rename from extra/math/text/authors.txt rename to extra/math/text/english/authors.txt diff --git a/extra/math/text/text-docs.factor b/extra/math/text/english/english-docs.factor similarity index 94% rename from extra/math/text/text-docs.factor rename to extra/math/text/english/english-docs.factor index 6a896b1a82..d544f49ad8 100644 --- a/extra/math/text/text-docs.factor +++ b/extra/math/text/english/english-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax math strings ; -IN: math.text +IN: math.text.english HELP: number>text { $values { "n" integer } { "str" string } } diff --git a/extra/math/text/text-tests.factor b/extra/math/text/english/english-tests.factor similarity index 93% rename from extra/math/text/text-tests.factor rename to extra/math/text/english/english-tests.factor index 09c8a0461b..00fccde1d3 100644 --- a/extra/math/text/text-tests.factor +++ b/extra/math/text/english/english-tests.factor @@ -1,4 +1,4 @@ -USING: math.functions math.text tools.test ; +USING: math.functions math.text.english tools.test ; IN: temporary [ "Zero" ] [ 0 number>text ] unit-test diff --git a/extra/math/text/text.factor b/extra/math/text/english/english.factor similarity index 96% rename from extra/math/text/text.factor rename to extra/math/text/english/english.factor index 7298fd3c15..a6179382bd 100644 --- a/extra/math/text/text.factor +++ b/extra/math/text/english/english.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: combinators.lib kernel math math.functions math.parser namespaces sequences splitting sequences.lib ; -IN: math.text +IN: math.text.english ] - } && and-needed? set drop ; + first { [ dup 100 < ] [ dup 0 > ] } && and-needed? set drop ; : negative-text ( n -- str ) 0 < "Negative " "" ? ; @@ -100,4 +97,3 @@ PRIVATE> ] [ [ (number>text) ] with-scope ] if ; - diff --git a/extra/math/text/english/summary.txt b/extra/math/text/english/summary.txt new file mode 100644 index 0000000000..cac4ccb222 --- /dev/null +++ b/extra/math/text/english/summary.txt @@ -0,0 +1 @@ +Convert integers to English text diff --git a/extra/math/text/summary.txt b/extra/math/text/summary.txt deleted file mode 100644 index 96b2f4f151..0000000000 --- a/extra/math/text/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Convert integers to text diff --git a/extra/porter-stemmer/porter-stemmer-tests.factor b/extra/porter-stemmer/porter-stemmer-tests.factor index 20050cc5e7..d3e031fdc6 100644 --- a/extra/porter-stemmer/porter-stemmer-tests.factor +++ b/extra/porter-stemmer/porter-stemmer-tests.factor @@ -56,7 +56,7 @@ io.files ; [ "hell" ] [ "hell" step5 "" like ] unit-test [ "mate" ] [ "mate" step5 "" like ] unit-test -: resource-lines resource-path lines ; +: resource-lines resource-path file-lines ; [ { } ] [ "extra/porter-stemmer/test/voc.txt" resource-lines diff --git a/extra/project-euler/002/002.factor b/extra/project-euler/002/002.factor index 386d847e27..b9375b7d1e 100644 --- a/extra/project-euler/002/002.factor +++ b/extra/project-euler/002/002.factor @@ -19,14 +19,18 @@ IN: project-euler.002 ! SOLUTION ! -------- -: last2 ( seq -- elt last ) - reverse first2 swap ; +r add dup 2 tail* sum r> (fib-upto) ] [ 2drop ] if ; + +PRIVATE> + +: fib-upto ( n -- seq ) + { 0 } 1 rot (fib-upto) ; : euler002 ( -- answer ) - 1000000 fib-up-to [ even? ] subset sum ; + 1000000 fib-upto [ even? ] subset sum ; ! [ euler002 ] 100 ave-time ! 0 ms run / 0 ms GC ave time - 100 trials diff --git a/extra/project-euler/003/003.factor b/extra/project-euler/003/003.factor index 2b229aa11b..afc4069aee 100644 --- a/extra/project-euler/003/003.factor +++ b/extra/project-euler/003/003.factor @@ -16,13 +16,10 @@ IN: project-euler.003 ! SOLUTION ! -------- -: largest-prime-factor ( n -- factor ) - factors supremum ; - : euler003 ( -- answer ) - 317584931803 largest-prime-factor ; + 317584931803 factors supremum ; -! [ euler003 ] time -! 2 ms run / 0 ms GC time +! [ euler003 ] 100 ave-time +! 1 ms run / 0 ms GC ave time - 100 trials MAIN: euler003 diff --git a/extra/project-euler/004/004.factor b/extra/project-euler/004/004.factor index dadde25411..0db0c6f2cb 100644 --- a/extra/project-euler/004/004.factor +++ b/extra/project-euler/004/004.factor @@ -26,14 +26,16 @@ IN: project-euler.004 : euler004 ( -- answer ) - 100 999 [a,b] [ 10 mod zero? not ] subset dup - cartesian-product [ product ] map prune max-palindrome ; + source-004 dup cartesian-product [ product ] map prune max-palindrome ; ! [ euler004 ] 100 ave-time ! 1608 ms run / 102 ms GC ave time - 100 trials diff --git a/extra/project-euler/005/005.factor b/extra/project-euler/005/005.factor index ff627e4a0e..0d8f11f243 100644 --- a/extra/project-euler/005/005.factor +++ b/extra/project-euler/005/005.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.functions sequences ; +USING: math math.functions sequences ; IN: project-euler.005 ! http://projecteuler.net/index.php?section=problems&id=5 diff --git a/extra/project-euler/007/007.factor b/extra/project-euler/007/007.factor index 12f06972a9..93754b69d1 100644 --- a/extra/project-euler/007/007.factor +++ b/extra/project-euler/007/007.factor @@ -18,12 +18,12 @@ IN: project-euler.007 ! -------- : nth-prime ( n -- n ) - 1 - lprimes lnth ; + 1- lprimes lnth ; : euler007 ( -- answer ) - 10001 nth-prime ; + 10001 nth-prime ; -! [ euler007 ] time -! 22 ms run / 0 ms GC time +! [ euler007 ] 100 ave-time +! 10 ms run / 0 ms GC ave time - 100 trials MAIN: euler007 diff --git a/extra/project-euler/008/008.factor b/extra/project-euler/008/008.factor index d76f344279..8b32d5651e 100644 --- a/extra/project-euler/008/008.factor +++ b/extra/project-euler/008/008.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math.parser project-euler.common sequences ; +USING: math.parser project-euler.common sequences ; IN: project-euler.008 ! http://projecteuler.net/index.php?section=problems&id=8 diff --git a/extra/project-euler/009/009.factor b/extra/project-euler/009/009.factor index 44569149d5..f09643d290 100644 --- a/extra/project-euler/009/009.factor +++ b/extra/project-euler/009/009.factor @@ -26,20 +26,18 @@ IN: project-euler.009 : next-pq ( p1 q1 -- p2 q2 ) ! p > q and both are odd integers - dup 1 = [ swap 2 + nip dup 2 - ] [ 2 - ] if ; + dup 1 = [ drop 2 + dup ] when 2 - ; : abc ( p q -- triplet ) [ - 2dup * , ! a = p * q - 2dup sq swap sq swap - 2 / , ! b = (p² - q²) / 2 - sq swap sq swap + 2 / , ! c = (p² + q²) / 2 + 2dup * , ! a = p * q + [ sq ] 2apply 2dup - 2 / , ! b = (p² - q²) / 2 + + 2 / , ! c = (p² + q²) / 2 ] { } make natural-sort ; : (ptriplet) ( target p q triplet -- target p q ) - roll dup >r swap sum = r> -roll - [ - next-pq 2dup abc (ptriplet) - ] unless ; + roll [ swap sum = ] keep -roll + [ next-pq 2dup abc (ptriplet) ] unless ; : ptriplet ( target -- triplet ) 3 1 { 3 4 5 } (ptriplet) abc nip ; diff --git a/extra/project-euler/010/010.factor b/extra/project-euler/010/010.factor index 1baf9500a1..172bb9d290 100644 --- a/extra/project-euler/010/010.factor +++ b/extra/project-euler/010/010.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007 Aaron Schaefer, Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math.primes sequences ; +USING: math.primes sequences ; IN: project-euler.010 ! http://projecteuler.net/index.php?section=problems&id=10 diff --git a/extra/project-euler/012/012.factor b/extra/project-euler/012/012.factor index 0d0d4161e4..3d59549e69 100644 --- a/extra/project-euler/012/012.factor +++ b/extra/project-euler/012/012.factor @@ -37,7 +37,7 @@ IN: project-euler.012 dup 1+ * 2 / ; : euler012 ( -- answer ) - 2 [ dup nth-triangle tau* 500 < ] [ 1+ ] [ ] while nth-triangle ; + 8 [ dup nth-triangle tau* 500 < ] [ 1+ ] [ ] while nth-triangle ; ! [ euler012 ] 10 ave-time ! 5413 ms run / 1 ms GC ave time - 10 trials diff --git a/extra/project-euler/013/013.factor b/extra/project-euler/013/013.factor index be968fc346..907029cfb2 100644 --- a/extra/project-euler/013/013.factor +++ b/extra/project-euler/013/013.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math.parser sequences ; +USING: math.parser sequences ; IN: project-euler.013 ! http://projecteuler.net/index.php?section=problems&id=13 diff --git a/extra/project-euler/014/014.factor b/extra/project-euler/014/014.factor index 7c1f0d41f9..02c5dbb9d3 100644 --- a/extra/project-euler/014/014.factor +++ b/extra/project-euler/014/014.factor @@ -39,7 +39,7 @@ IN: project-euler.014 dup even? [ 2 / ] [ 3 * 1+ ] if ; : longest ( seq seq -- seq ) - 2dup length swap length > [ nip ] [ drop ] if ; + 2dup [ length ] 2apply > [ drop ] [ nip ] if ; PRIVATE> @@ -47,7 +47,7 @@ PRIVATE> [ [ dup 1 > ] [ dup , next-collatz ] [ ] while , ] { } make ; : euler014 ( -- answer ) - 1000000 0 [ 1+ collatz longest ] reduce first ; + 1000000 [1,b] 0 [ collatz longest ] reduce first ; ! [ euler014 ] time ! 52868 ms run / 483 ms GC time @@ -59,10 +59,7 @@ PRIVATE> @@ -72,7 +69,7 @@ PRIVATE> ] reduce first ; ! [ euler014a ] 10 ave-time -! 5109 ms run / 44 ms GC time +! 4821 ms run / 41 ms GC time ! TODO: try using memoization diff --git a/extra/project-euler/016/016.factor b/extra/project-euler/016/016.factor index 866b0ed522..00747a9317 100644 --- a/extra/project-euler/016/016.factor +++ b/extra/project-euler/016/016.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math.functions math.parser project-euler.common sequences ; +USING: math.functions math.parser project-euler.common sequences ; IN: project-euler.016 ! http://projecteuler.net/index.php?section=problems&id=16 diff --git a/extra/project-euler/017/017.factor b/extra/project-euler/017/017.factor index 1fdb6c5484..296818db07 100644 --- a/extra/project-euler/017/017.factor +++ b/extra/project-euler/017/017.factor @@ -1,7 +1,6 @@ -! Copyright (c) 2007 Samuel Tardieu, Aaron Schaefer. +! Copyright (c) 2007 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators.lib kernel math math.ranges math.text namespaces sequences - strings ; +USING: combinators.lib kernel math.ranges math.text.english sequences strings ; IN: project-euler.017 ! http://projecteuler.net/index.php?section=problems&id=17 @@ -23,55 +22,10 @@ IN: project-euler.017 ! SOLUTION ! -------- - - -: >english ( n -- str ) - [ make-english ] "" make ; - : euler017 ( -- answer ) - 1000 [1,b] [ >english [ letter? ] subset length ] map sum ; - -! [ euler017 ] 100 ave-time -! 9 ms run / 0 ms GC ave time - 100 trials - - -! ALTERNATE SOLUTIONS -! ------------------- - -: euler017a ( -- answer ) 1000 [1,b] SBUF" " clone [ number>text over push-all ] reduce [ Letter? ] count ; ! [ euler017a ] 100 ave-time -! 14 ms run / 1 ms GC ave time - 100 trials +! 14 ms run / 0 ms GC ave time - 100 trials MAIN: euler017 diff --git a/extra/project-euler/018/018.factor b/extra/project-euler/018/018.factor index 2dc05db1b1..eb2df5e0da 100644 --- a/extra/project-euler/018/018.factor +++ b/extra/project-euler/018/018.factor @@ -50,39 +50,28 @@ IN: project-euler.018 -! Propagate one row into the upper one -: propagate ( bottom top -- newtop ) - [ over 1 tail rot first2 max rot + ] map nip ; - -! Not strictly needed, but it is nice to be able to dump the pyramid after -! the propagation -: propagate-all ( pyramid -- newpyramid ) - reverse [ first dup ] keep 1 tail [ propagate dup ] map nip reverse swap add ; - : euler018 ( -- answer ) - pyramid propagate-all first first ; + source-018 propagate-all first first ; ! [ euler018 ] 100 ave-time ! 0 ms run / 0 ms GC ave time - 100 trials @@ -91,31 +80,10 @@ PRIVATE> ! ALTERNATE SOLUTIONS ! ------------------- - - : euler018a ( -- answer ) - source-018a max-path ; + source-018 max-path ; ! [ euler018a ] 100 ave-time ! 0 ms run / 0 ms GC ave time - 100 trials -MAIN: euler018 +MAIN: euler018a diff --git a/extra/project-euler/019/019.factor b/extra/project-euler/019/019.factor index f811b98e10..58a2dc9668 100644 --- a/extra/project-euler/019/019.factor +++ b/extra/project-euler/019/019.factor @@ -30,9 +30,10 @@ IN: project-euler.019 ! already, as "zeller-congruence ( year month day -- n )" where n is ! the day of the week (Sunday is 0). -: euler019 ( -- count ) - 1901 2000 [a,b] [ 12 [1,b] [ 1 zeller-congruence ] 1 map-withn ] map concat - [ 0 = ] subset length ; +: euler019 ( -- answer ) + 1901 2000 [a,b] [ + 12 [1,b] [ 1 zeller-congruence ] 1 map-withn + ] map concat [ zero? ] count ; ! [ euler019 ] 100 ave-time ! 1 ms run / 0 ms GC ave time - 100 trials diff --git a/extra/project-euler/020/020.factor b/extra/project-euler/020/020.factor index 498aad16ad..8ac75bd9ff 100644 --- a/extra/project-euler/020/020.factor +++ b/extra/project-euler/020/020.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math.combinatorics math.parser project-euler.common sequences ; +USING: math.combinatorics math.parser project-euler.common sequences ; IN: project-euler.020 ! http://projecteuler.net/index.php?section=problems&id=20 diff --git a/extra/project-euler/022/022.factor b/extra/project-euler/022/022.factor index f523f586c5..b4910e5885 100644 --- a/extra/project-euler/022/022.factor +++ b/extra/project-euler/022/022.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2007 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators.lib io io.files kernel math math.parser namespaces sequences - sorting splitting strings system vocabs ; +USING: io.files kernel math math.parser namespaces sequences sorting splitting + strings system vocabs ; IN: project-euler.022 ! http://projecteuler.net/index.php?section=problems&id=22 @@ -27,21 +27,12 @@ IN: project-euler.022 digits [ 9 - ] sigma ; + [ string>digits sum ] keep length 9 * - ; : name-scores ( seq -- seq ) dup length [ 1+ swap alpha-value * ] 2map ; diff --git a/extra/project-euler/023/023.factor b/extra/project-euler/023/023.factor new file mode 100644 index 0000000000..06f6555ea3 --- /dev/null +++ b/extra/project-euler/023/023.factor @@ -0,0 +1,61 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: hashtables kernel math math.ranges project-euler.common sequences + sorting ; +IN: project-euler.023 + +! http://projecteuler.net/index.php?section=problems&id=23 + +! DESCRIPTION +! ----------- + +! A perfect number is a number for which the sum of its proper divisors is +! exactly equal to the number. For example, the sum of the proper divisors of +! 28 would be 1 + 2 + 4 + 7 + 14 = 28, which means that 28 is a perfect number. + +! A number whose proper divisors are less than the number is called deficient +! and a number whose proper divisors exceed the number is called abundant. + +! As 12 is the smallest abundant number, 1 + 2 + 3 + 4 + 6 = 16, the smallest +! number that can be written as the sum of two abundant numbers is 24. By +! mathematical analysis, it can be shown that all integers greater than 28123 +! can be written as the sum of two abundant numbers. However, this upper limit +! cannot be reduced any further by analysis even though it is known that the +! greatest number that cannot be expressed as the sum of two abundant numbers +! is less than this limit. + +! Find the sum of all the positive integers which cannot be written as the sum +! of two abundant numbers. + + +! SOLUTION +! -------- + +! The upper limit can be dropped to 20161 which reduces our search space +! and every even number > 46 can be expressed as a sum of two abundants + + append ; + +: abundants-upto ( n -- seq ) + [1,b] [ abundant? ] subset ; + +: possible-sums ( seq -- seq ) + dup { } -rot [ + dupd [ + ] curry map + rot append prune swap 1 tail + ] each drop natural-sort ; + +PRIVATE> + +: euler023 ( -- answer ) + 20161 abundants-upto possible-sums source-023 seq-diff sum ; + +! TODO: solution is still too slow, although it takes under 1 minute + +! [ euler023 ] time +! 52780 ms run / 3839 ms GC + +MAIN: euler023 diff --git a/extra/project-euler/024/024.factor b/extra/project-euler/024/024.factor new file mode 100644 index 0000000000..44434b4a88 --- /dev/null +++ b/extra/project-euler/024/024.factor @@ -0,0 +1,48 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.parser math.ranges namespaces sequences ; +IN: project-euler.024 + +! http://projecteuler.net/index.php?section=problems&id=24 + +! DESCRIPTION +! ----------- + +! A permutation is an ordered arrangement of objects. For example, 3124 is one +! possible permutation of the digits 1, 2, 3 and 4. If all of the permutations +! are listed numerically or alphabetically, we call it lexicographic order. The +! lexicographic permutations of 0, 1 and 2 are: + +! 012 021 102 120 201 210 + +! What is the millionth lexicographic permutation of the digits 0, 1, 2, 3, 4, +! 5, 6, 7, 8 and 9? + + +! SOLUTION +! -------- + +permutation) ( seq n -- seq ) + [ [ dupd >= [ 1+ ] when ] curry map ] keep add* ; + +PRIVATE> + +: >permutation ( factoradic -- permutation ) + reverse 1 cut [ (>permutation) ] each ; + +: factoradic ( k order -- factoradic ) + [ [1,b] [ 2dup mod , /i ] each ] { } make reverse nip ; + +: permutation ( k seq -- seq ) + dup length swapd factoradic >permutation + [ [ dupd swap nth , ] each drop ] { } make ; + +: euler024 ( -- answer ) + 999999 10 permutation 10 swap digits>integer ; + +! [ euler024 ] 100 ave-time +! 0 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler024 diff --git a/extra/project-euler/025/025.factor b/extra/project-euler/025/025.factor new file mode 100644 index 0000000000..2819e210a7 --- /dev/null +++ b/extra/project-euler/025/025.factor @@ -0,0 +1,84 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.syntax kernel math math.functions math.parser math.ranges memoize + project-euler.common sequences ; +IN: project-euler.025 + +! http://projecteuler.net/index.php?section=problems&id=25 + +! DESCRIPTION +! ----------- + +! The Fibonacci sequence is defined by the recurrence relation: + +! Fn = Fn-1 + Fn-2, where F1 = 1 and F2 = 1. + +! Hence the first 12 terms will be: + +! F1 = 1 +! F2 = 1 +! F3 = 2 +! F4 = 3 +! F5 = 5 +! F6 = 8 +! F7 = 13 +! F8 = 21 +! F9 = 34 +! F10 = 55 +! F11 = 89 +! F12 = 144 + +! The 12th term, F12, is the first term to contain three digits. + +! What is the first term in the Fibonacci sequence to contain 1000 digits? + + +! SOLUTION +! -------- + +! Memoized brute force + +MEMO: fib ( m -- n ) + dup 1 > [ 1- dup fib swap 1- fib + ] when ; + +string length > [ 1+ (digit-fib) ] [ nip ] if ; + +: digit-fib ( n -- term ) + 1 (digit-fib) ; + +PRIVATE> + +: euler025 ( -- answer ) + 1000 digit-fib ; + +! [ euler025 ] 10 ave-time +! 5237 ms run / 72 ms GC ave time - 10 trials + + +! ALTERNATE SOLUTIONS +! ------------------- + +! A number containing 1000 digits is the same as saying it's greater than 10**999 +! The nth Fibonacci number is Phi**n / sqrt(5) rounded to the nearest integer +! Thus we need we need "Phi**n / sqrt(5) > 10**999", and we just solve for n + +integer ; + +PRIVATE> + +: euler025a ( -- answer ) + 1000 digit-fib* ; + +! [ euler025a ] 100 ave-time +! 0 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler025a diff --git a/extra/project-euler/067/067.factor b/extra/project-euler/067/067.factor index a675a5635e..5df516f2f4 100644 --- a/extra/project-euler/067/067.factor +++ b/extra/project-euler/067/067.factor @@ -1,7 +1,6 @@ ! Copyright (c) 2007 Samuel Tardieu, Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: io io.files kernel math.parser namespaces project-euler.018 - project-euler.common sequences splitting system vocabs ; +USING: io.files math.parser namespaces project-euler.common sequences splitting ; IN: project-euler.067 ! http://projecteuler.net/index.php?section=problems&id=67 @@ -37,14 +36,14 @@ IN: project-euler.067 lines [ " " split [ string>number ] map ] map ; +: source-067 ( -- seq ) + "extra/project-euler/067/triangle.txt" resource-path + file-lines [ " " split [ string>number ] map ] map ; PRIVATE> : euler067 ( -- answer ) - pyramid propagate-all first first ; + source-067 propagate-all first first ; ! [ euler067 ] 100 ave-time ! 18 ms run / 0 ms GC time @@ -53,30 +52,13 @@ PRIVATE> ! ALTERNATE SOLUTIONS ! ------------------- - lines [ " " split [ string>number ] map ] map ; - -PRIVATE> - : euler067a ( -- answer ) - source-067a max-path ; + source-067 max-path ; ! [ euler067a ] 100 ave-time -! 15 ms run / 0 ms GC ave time - 100 trials +! 14 ms run / 0 ms GC ave time - 100 trials -! source-067a [ max-path ] curry 100 ave-time +! source-067 [ max-path ] curry 100 ave-time ! 3 ms run / 0 ms GC ave time - 100 trials MAIN: euler067a diff --git a/extra/project-euler/134/134.factor b/extra/project-euler/134/134.factor index 55f8a8dab8..fb7fdebd51 100644 --- a/extra/project-euler/134/134.factor +++ b/extra/project-euler/134/134.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2007 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel lazy-lists math.algebra math math.functions math.primes - math.ranges sequences ; + math.ranges project-euler.common sequences ; IN: project-euler.134 ! http://projecteuler.net/index.php?section=problems&id=134 @@ -9,34 +9,40 @@ IN: project-euler.134 ! DESCRIPTION ! ----------- -! Consider the consecutive primes p1 = 19 and p2 = 23. It can be -! verified that 1219 is the smallest number such that the last digits -! are formed by p1 whilst also being divisible by p2. +! Consider the consecutive primes p1 = 19 and p2 = 23. It can be verified that +! 1219 is the smallest number such that the last digits are formed by p1 whilst +! also being divisible by p2. ! In fact, with the exception of p1 = 3 and p2 = 5, for every pair of -! consecutive primes, p2 p1, there exist values of n for which the last -! digits are formed by p1 and n is divisible by p2. Let S be the -! smallest of these values of n. +! consecutive primes, p2 p1, there exist values of n for which the last digits +! are formed by p1 and n is divisible by p2. Let S be the smallest of these +! values of n. ! Find S for every pair of consecutive primes with 5 p1 1000000. + ! SOLUTION ! -------- -! Compute the smallest power of 10 greater than m or equal to it +! Compute the smallest power of 10 greater than or equal to m : next-power-of-10 ( m -- n ) - 10 swap log 10 log / ceiling >integer ^ ; foldable + 10 swap log10 ceiling >integer ^ ; foldable + + : euler134 ( -- answer ) - 0 5 lprimes-from uncons [ 1000000 > ] luntil [ [ s + ] keep ] leach drop ; + 0 5 lprimes-from uncons [ 1000000 > ] luntil + [ [ s + ] keep ] leach drop ; ! [ euler134 ] 10 ave-time -! 3797 ms run / 30 ms GC ave time - 10 trials +! 2430 ms run / 36 ms GC ave time - 10 trials MAIN: euler134 diff --git a/extra/project-euler/169/169.factor b/extra/project-euler/169/169.factor index 959715e4f9..61645bf50b 100644 --- a/extra/project-euler/169/169.factor +++ b/extra/project-euler/169/169.factor @@ -8,11 +8,11 @@ USING: combinators kernel math math.functions memoize ; ! DESCRIPTION ! ----------- -! Define f(0)=1 and f(n) to be the number of different ways n can be -! expressed as a sum of integer powers of 2 using each power no more -! than twice. +! Define f(0) = 1 and f(n) to be the number of different ways n can be +! expressed as a sum of integer powers of 2 using each power no more than +! twice. -! For example, f(10)=5 since there are five different ways to express 10: +! For example, f(10) = 5 since there are five different ways to express 10: ! 1 + 1 + 8 ! 1 + 1 + 4 + 4 @@ -22,18 +22,19 @@ USING: combinators kernel math math.functions memoize ; ! What is f(1025)? + ! SOLUTION ! -------- MEMO: fn ( n -- x ) - { - { [ dup 2 < ] [ drop 1 ] } - { [ dup odd? ] [ 2/ fn ] } - { [ t ] [ 2/ [ fn ] keep 1- fn + ] } - } cond ; + { + { [ dup 2 < ] [ drop 1 ] } + { [ dup odd? ] [ 2/ fn ] } + { [ t ] [ 2/ [ fn ] keep 1- fn + ] } + } cond ; : euler169 ( -- result ) - 10 25 ^ fn ; + 10 25 ^ fn ; ! [ euler169 ] 100 ave-time ! 0 ms run / 0 ms GC ave time - 100 trials diff --git a/extra/project-euler/173/173.factor b/extra/project-euler/173/173.factor index 4eef3ec3e2..9f2984d37d 100644 --- a/extra/project-euler/173/173.factor +++ b/extra/project-euler/173/173.factor @@ -1,4 +1,4 @@ -! Copyright (c) 2007 Aaron Schaefer. +! Copyright (c) 2007 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math math.functions math.ranges sequences ; IN: project-euler.173 @@ -8,25 +8,29 @@ IN: project-euler.173 ! DESCRIPTION ! ----------- -! We shall define a square lamina to be a square outline with a square -! "hole" so that the shape possesses vertical and horizontal -! symmetry. For example, using exactly thirty-two square tiles we can -! form two different square laminae: [see URL for figure] +! We shall define a square lamina to be a square outline with a square "hole" +! so that the shape possesses vertical and horizontal symmetry. For example, +! using exactly thirty-two square tiles we can form two different square +! laminae: [see URL for figure] -! With one-hundred tiles, and not necessarily using all of the tiles at -! one time, it is possible to form forty-one different square laminae. +! With one-hundred tiles, and not necessarily using all of the tiles at one +! time, it is possible to form forty-one different square laminae. + +! Using up to one million tiles how many different square laminae can be formed? -! Using up to one million tiles how many different square laminae can be -! formed? ! SOLUTION ! -------- -: laminaes ( upper -- n ) - 4 / dup sqrt [1,b] 0 rot [ over /mod drop - - ] curry reduce ; + : euler173 ( -- answer ) - 1000000 laminaes ; + 1000000 laminae ; ! [ euler173 ] 100 ave-time ! 0 ms run / 0 ms GC ave time - 100 trials diff --git a/extra/project-euler/175/175.factor b/extra/project-euler/175/175.factor index db1760c017..e6b4acc8c0 100644 --- a/extra/project-euler/175/175.factor +++ b/extra/project-euler/175/175.factor @@ -8,45 +8,49 @@ IN: project-euler.175 ! DESCRIPTION ! ----------- -! Define f(0)=1 and f(n) to be the number of ways to write n as a sum of +! Define f(0) = 1 and f(n) to be the number of ways to write n as a sum of ! powers of 2 where no power occurs more than twice. -! For example, f(10)=5 since there are five different ways to express +! For example, f(10) = 5 since there are five different ways to express ! 10: 10 = 8+2 = 8+1+1 = 4+4+2 = 4+2+2+1+1 = 4+4+1+1 -! It can be shown that for every fraction p/q (p0, q0) there exists at -! least one integer n such that f(n)/f(n-1)=p/q. +! It can be shown that for every fraction p/q (p0, q0) there exists at least +! one integer n such that f(n) / f(n-1) = p/q. -! For instance, the smallest n for which f(n)/f(n-1)=13/17 is 241. The -! binary expansion of 241 is 11110001. Reading this binary number from -! the most significant bit to the least significant bit there are 4 -! one's, 3 zeroes and 1 one. We shall call the string 4,3,1 the -! Shortened Binary Expansion of 241. +! For instance, the smallest n for which f(n) / f(n-1) = 13/17 is 241. The +! binary expansion of 241 is 11110001. Reading this binary number from the most +! significant bit to the least significant bit there are 4 one's, 3 zeroes and +! 1 one. We shall call the string 4,3,1 the Shortened Binary Expansion of 241. ! Find the Shortened Binary Expansion of the smallest n for which -! f(n)/f(n-1)=123456789/987654321. +! f(n) / f(n-1) = 123456789/987654321. ! Give your answer as comma separated integers, without any whitespaces. + ! SOLUTION ! -------- +integer 0 add-bits ] } - } cond ; + { + { [ dup integer? ] [ 1- 0 add-bits ] } + { [ dup 1 < ] [ 1 over - / dupd compute 1 1 add-bits ] } + { [ t ] [ [ 1 mod compute ] 2keep >integer 0 add-bits ] } + } cond ; + +PRIVATE> : euler175 ( -- result ) - V{ 1 } clone dup 123456789/987654321 compute [ number>string ] map "," join ; + V{ 1 } clone dup 123456789/987654321 compute [ number>string ] map "," join ; ! [ euler175 ] 100 ave-time ! 0 ms run / 0 ms GC ave time - 100 trials diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor index 2e18d744fc..6279606481 100644 --- a/extra/project-euler/common/common.factor +++ b/extra/project-euler/common/common.factor @@ -1,31 +1,51 @@ -USING: arrays kernel hashtables math math.functions math.miller-rabin - math.parser math.ranges namespaces sequences combinators.lib ; +USING: kernel math math.functions math.miller-rabin math.parser + math.primes.factors math.ranges namespaces sequences ; IN: project-euler.common -! A collection of words used by more than one Project Euler solution. +! A collection of words used by more than one Project Euler solution +! and/or related words that could be useful for future problems. + +! Problems using each public word +! ------------------------------- +! collect-consecutive - #8, #11 +! log10 - #25, #134 +! max-path - #18, #67 +! number>digits - #16, #20 +! propagate-all - #18, #67 +! sum-proper-divisors - #21 +! tau* - #12 + : nth-pair ( n seq -- nth next ) over 1+ over nth >r nth r> ; +: perfect-square? ( n -- ? ) + dup sqrt mod zero? ; + r length 1+ r> - ; -: shift-3rd ( seq obj obj -- seq obj obj ) - rot 1 tail -rot ; - : max-children ( seq -- seq ) [ dup length 1- [ over nth-pair max , ] each ] { } make nip ; -: >multiplicity ( seq -- seq ) - dup prune [ - [ 2dup [ = ] curry count 2array , ] each - ] { } make nip ; inline +! Propagate one row into the upper one +: propagate ( bottom top -- newtop ) + [ over 1 tail rot first2 max rot + ] map nip ; : reduce-2s ( n -- r s ) dup even? [ factor-2s >r 1+ r> ] [ 1 swap ] if ; +: shift-3rd ( seq obj obj -- seq obj obj ) + rot 1 tail -rot ; + +: (sum-divisors) ( n -- sum ) + dup sqrt >fixnum [1,b] [ + [ 2dup mod zero? [ 2dup / + , ] [ drop ] if ] each + dup perfect-square? [ sqrt >fixnum neg , ] [ drop ] if + ] { } make sum ; + PRIVATE> : collect-consecutive ( seq width -- seq ) @@ -33,8 +53,8 @@ PRIVATE> 2dup count-shifts [ 2dup head shift-3rd , ] times ] { } make 2nip ; -: divisor? ( n m -- ? ) - mod zero? ; +: log10 ( m -- n ) + log 10 log / ; : max-path ( triangle -- n ) dup length 1 > [ @@ -46,27 +66,10 @@ PRIVATE> : number>digits ( n -- seq ) number>string string>digits ; -: perfect-square? ( n -- ? ) - dup sqrt divisor? ; - -: prime-factorization ( n -- seq ) - [ - 2 [ over 1 > ] - [ 2dup divisor? [ dup , [ / ] keep ] [ next-prime ] if ] - [ ] while 2drop - ] { } make ; - -: prime-factorization* ( n -- seq ) - prime-factorization >multiplicity ; - -: prime-factors ( n -- seq ) - prime-factorization prune >array ; - -: (sum-divisors) ( n -- sum ) - dup sqrt >fixnum [1,b] [ - [ 2dup divisor? [ 2dup / + , ] [ drop ] if ] each - dup perfect-square? [ sqrt >fixnum neg , ] [ drop ] if - ] { } make sum ; +! Not strictly needed, but it is nice to be able to dump the triangle after the +! propagation +: propagate-all ( triangle -- newtriangle ) + reverse [ first dup ] keep 1 tail [ propagate dup ] map nip reverse swap add ; : sum-divisors ( n -- sum ) dup 4 < [ { 0 1 3 4 } nth ] [ (sum-divisors) ] if ; @@ -84,12 +87,12 @@ PRIVATE> dup sum-proper-divisors = ; ! The divisor function, counts the number of divisors -: tau ( n -- n ) - prime-factorization* flip second 1 [ 1+ * ] reduce ; +: tau ( m -- n ) + count-factors flip second 1 [ 1+ * ] reduce ; ! Optimized brute-force, is often faster than prime factorization -: tau* ( n -- n ) +: tau* ( m -- n ) reduce-2s [ perfect-square? -1 0 ? ] keep dup sqrt >fixnum [1,b] [ - dupd divisor? [ >r 2 + r> ] when + dupd mod zero? [ >r 2 + r> ] when ] each drop * ; diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 250a92b953..038ae3c5b8 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -7,7 +7,9 @@ USING: definitions io io.files kernel math.parser sequences vocabs project-euler.009 project-euler.010 project-euler.011 project-euler.012 project-euler.013 project-euler.014 project-euler.015 project-euler.016 project-euler.017 project-euler.018 project-euler.019 project-euler.020 - project-euler.021 project-euler.022 project-euler.067 project-euler.134 ; + project-euler.021 project-euler.022 project-euler.023 project-euler.024 + project-euler.025 project-euler.067 project-euler.134 project-euler.169 + project-euler.173 project-euler.175 ; IN: project-euler diff --git a/extra/ui/freetype/freetype.factor b/extra/ui/freetype/freetype.factor index 9456c6fe69..48164c08f6 100644 --- a/extra/ui/freetype/freetype.factor +++ b/extra/ui/freetype/freetype.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays io kernel libc math math.vectors namespaces opengl opengl.gl prettyprint assocs sequences io.files io.styles continuations freetype -ui.gadgets.worlds ui.render ui.backend ; +ui.gadgets.worlds ui.render ui.backend io.mmap ; IN: ui.freetype TUPLE: freetype-renderer ; @@ -63,9 +63,16 @@ M: freetype-renderer free-fonts ( world -- ) : ttf-path ( name -- string ) "/fonts/" swap ".ttf" 3append resource-path ; +: (open-face) ( mapped-file -- face ) + #! We use FT_New_Memory_Face, not FT_New_Face, since + #! FT_New_Face only takes an ASCII path name and causes + #! problems on localized versions of Windows + freetype swap dup mapped-file-address swap length 0 f + [ FT_New_Memory_Face freetype-error ] keep *void* ; + : open-face ( font style -- face ) - ttf-name ttf-path >r freetype r> - 0 f [ FT_New_Face freetype-error ] keep *void* ; + ttf-name ttf-path dup file-length + (open-face) ; : dpi 72 ; inline diff --git a/extra/unicode/breaks/breaks.factor b/extra/unicode/breaks/breaks.factor index 8c3dffcc2d..fc1e3071e7 100644 --- a/extra/unicode/breaks/breaks.factor +++ b/extra/unicode/breaks/breaks.factor @@ -30,10 +30,9 @@ CATEGORY: grapheme-control Zl Zp Cc Cf ; concat >set ; : other-extend-lines ( -- lines ) - "extra/unicode/PropList.txt" resource-path lines ; + "extra/unicode/PropList.txt" resource-path file-lines ; DEFER: other-extend -<< other-extend-lines process-other-extend \ other-extend define-value >> CATEGORY: (extend) Me Mn ; : extend? ( ch -- ? ) @@ -79,11 +78,6 @@ SYMBOL: table graphemes Extend connect-after ; DEFER: grapheme-table -<< - init-grapheme-table table - [ make-grapheme-table finish-table ] with-variable - \ grapheme-table define-value ->> : grapheme-break? ( class1 class2 -- ? ) grapheme-table nth nth not ; @@ -125,3 +119,11 @@ DEFER: grapheme-table : prev-grapheme ( i str -- prev-i ) prev-grapheme-step (prev-grapheme) ; + +[ + other-extend-lines process-other-extend \ other-extend define-value + + init-grapheme-table table + [ make-grapheme-table finish-table ] with-variable + \ grapheme-table define-value +] with-compilation-unit diff --git a/extra/unicode/categories/categories-tests.factor b/extra/unicode/categories/categories-tests.factor index 6bbe6b057a..81868709e3 100644 --- a/extra/unicode/categories/categories-tests.factor +++ b/extra/unicode/categories/categories-tests.factor @@ -3,5 +3,5 @@ USING: tools.test kernel unicode.categories words sequences unicode.syntax ; [ { f f t t f t t f f t } ] [ CHAR: A { blank? letter? LETTER? Letter? digit? printable? alpha? control? uncased? character? -} [ execute ] curry* map ] unit-test +} [ execute ] with map ] unit-test [ "Nd" ] [ CHAR: 3 category ] unit-test diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor index 49f77a61d8..e112471c28 100644 --- a/extra/unicode/data/data.factor +++ b/extra/unicode/data/data.factor @@ -1,6 +1,6 @@ -USING: assocs math kernel sequences io.files hashtables quotations -splitting arrays math.parser combinators.lib hash2 byte-arrays words -namespaces words ; +USING: assocs math kernel sequences io.files hashtables +quotations splitting arrays math.parser combinators.lib hash2 +byte-arrays words namespaces words compiler.units ; IN: unicode.data ! Convenience functions @@ -116,19 +116,7 @@ DEFER: class-map DEFER: compat-map DEFER: category-map DEFER: name-map - -<< - load-data - dup process-names \ name-map define-value - 13 over process-data \ simple-lower define-value - 12 over process-data tuck \ simple-upper define-value - 14 over process-data swapd union \ simple-title define-value - dup process-combining \ class-map define-value - dup process-canonical \ canonical-map define-value - \ combine-map define-value - dup process-compat \ compat-map define-value - process-category \ category-map define-value ->> +DEFER: special-casing : canonical-entry ( char -- seq ) canonical-map at ; : combine-chars ( a b -- char/f ) combine-map hash2 ; @@ -144,6 +132,16 @@ DEFER: name-map [ length 5 = ] subset [ [ set-code-point ] each ] H{ } make-assoc ; -DEFER: special-casing - -<< load-special-casing \ special-casing define-value >> +[ + load-data + dup process-names \ name-map define-value + 13 over process-data \ simple-lower define-value + 12 over process-data tuck \ simple-upper define-value + 14 over process-data swapd union \ simple-title define-value + dup process-combining \ class-map define-value + dup process-canonical \ canonical-map define-value + \ combine-map define-value + dup process-compat \ compat-map define-value + process-category \ category-map define-value + load-special-casing \ special-casing define-value +] with-compilation-unit diff --git a/extra/unicode/normalize/normalize.factor b/extra/unicode/normalize/normalize.factor index a1386d84ae..86a922793f 100644 --- a/extra/unicode/normalize/normalize.factor +++ b/extra/unicode/normalize/normalize.factor @@ -1,5 +1,5 @@ -USING: sequences namespaces unicode.data kernel combinators.lib math -unicode arrays ; +USING: sequences namespaces unicode.data kernel combinators.lib +math arrays ; IN: unicode.normalize ! Utility word @@ -89,7 +89,7 @@ IN: unicode.normalize swap [ [ dup hangul? [ hangul>jamo % drop ] [ dup rot call [ % ] [ , ] ?if ] if - ] curry* each ] "" make* + ] with each ] "" make* dup reorder ] if ; inline diff --git a/extra/unicode/syntax/syntax.factor b/extra/unicode/syntax/syntax.factor index 3992a73c1f..91d46d179f 100644 --- a/extra/unicode/syntax/syntax.factor +++ b/extra/unicode/syntax/syntax.factor @@ -20,10 +20,10 @@ IN: unicode.syntax category# categories nth ; : >category-array ( categories -- bitarray ) - categories [ swap member? ] curry* map >bit-array ; + categories [ swap member? ] with map >bit-array ; : as-string ( strings -- bit-array ) - concat "\"" tuck 3append parse first ; + concat "\"" tuck 3append eval ; : [category] ( categories -- quot ) [ diff --git a/extra/webapps/cgi/cgi.factor b/extra/webapps/cgi/cgi.factor index 3588b21bda..26b8f31eae 100644 --- a/extra/webapps/cgi/cgi.factor +++ b/extra/webapps/cgi/cgi.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces kernel assocs io.files combinators -arrays io.launcher io http.server http.server.responders -webapps.file sequences strings ; +arrays io.launcher io http.server.responders webapps.file +sequences strings ; IN: webapps.cgi SYMBOL: cgi-root diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index d6b1066083..da6cf6dfcc 100644 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -122,6 +122,9 @@ SYMBOL: last-update { "Doug Coleman" "http://code-factor.blogspot.com/feeds/posts/default" "http://code-factor.blogspot.com/" } { "Daniel Ehrenberg" "http://useless-factor.blogspot.com/feeds/posts/default" "http://useless-factor.blogspot.com/" } { "Gavin Harrison" "http://gmh33.blogspot.com/feeds/posts/default" "http://gmh33.blogspot.com/" } + { "Kevin Marshall" + "http://blog.botfu.com/?cat=9&feed=atom" + "http://blog.botfu.com/" } { "Kio M. Smallwood" "http://sekenre.wordpress.com/feed/atom/" "http://sekenre.wordpress.com/" } diff --git a/extra/xml/utilities/utilities.factor b/extra/xml/utilities/utilities.factor index 5175711408..d6814851ee 100755 --- a/extra/xml/utilities/utilities.factor +++ b/extra/xml/utilities/utilities.factor @@ -23,7 +23,7 @@ M: process-missing error. : PROCESS: CREATE dup H{ } clone "xtable" set-word-prop - dup [ run-process ] curry define-compound ; parsing + dup [ run-process ] curry define ; parsing : TAG: scan scan-word diff --git a/extra/xml/xml-docs.factor b/extra/xml/xml-docs.factor index 785538332a..a941e0de92 100644 --- a/extra/xml/xml-docs.factor +++ b/extra/xml/xml-docs.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2005, 2006 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax kernel xml xml.data xml.errors +USING: help.markup help.syntax kernel xml.data xml.errors xml.writer state-parser xml.tokenize xml.utilities xml.entities strings sequences io ; +IN: xml HELP: string>xml { $values { "string" "a string" } { "xml" "an xml document" } }