steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge git://factorcode.org/git/factor 

Conflicts:

	extra/html/elements/elements.factor
db4
Doug Coleman 2008-01-10 20:51:50 -10:00
parent 9a599ec459 d2222179c6
commit 1a2ca6e463
66 changed files with 593 additions and 465 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
core/compiler/errors/errors.factor
View File

@ -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 ( -- )

2
extra/assocs/lib/lib.factor
View File

@ -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* ;

51
extra/calendar/calendar.factor
View File

@ -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 <timestamp> ;
: 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" <c-object>
[ 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" ] }

4
extra/concurrency/concurrency.factor
View File

@ -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.

2
extra/const/const.factor
View File

@ -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:

3
extra/crypto/common/common-docs.factor
View File

@ -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" } }

44
extra/freetype/freetype.factor
View File

@ -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 ) ;

15
extra/furnace/furnace.factor
View File

@ -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 ;

2
extra/help/cookbook/cookbook.factor
View File

@ -199,7 +199,7 @@ ARTICLE: "cookbook-io" "I/O cookbook"
}
"Print the lines of a file in sorted order:"
{ $code
"\"lines.txt\" <file-reader> lines natural-sort [ print ] each"
"\"lines.txt\" file-lines natural-sort [ print ] each"
}
"Read 1024 bytes from a file:"
{ $code

2
extra/help/markup/markup.factor
View File

@ -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 -- )

8
extra/html/elements/elements-tests.factor Normal file
View File

@ -0,0 +1,8 @@
IN: temporary
USING: tools.test html html.elements io.streams.string ;
: make-html-string
[ with-html-stream ] string-out ;
[ "<a href='h&amp;o'>" ]
[ [ <a "h&o" =href a> ] make-html-string ] unit-test

91
extra/html/elements/elements.factor
View File

@ -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:
!
!
! <p> "someoutput" write </p>
!
! <p> will output the opening tag and </p> 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 ;
: <foo> "<" swap ">" 3append ;
: empty-effect T{ effect f 0 0 } ;
: def-for-html-word-<foo> ( name -- )
#! Return the name and code for the <foo> patterned
#! word.
dup <foo> swap [ <foo> write-html ] curry html-word ;
dup <foo> swap [ <foo> write-html ] curry
empty-effect html-word ;
: <foo "<" swap append ;
: def-for-html-word-<foo ( name -- )
#! Return the name and code for the <foo patterned
#! word.
<foo dup [ write-html ] curry html-word ;
<foo dup [ 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 ;
foo> [ ">" write-html ] empty-effect html-word ;
: </foo> [ "</" % % ">" % ] "" make ;
: def-for-html-word-</foo> ( name -- )
#! Return the name and code for the </foo> patterned
#! word.
</foo> dup [ write-html ] curry html-word ;
#! word.
</foo> dup [ write-html ] curry empty-effect html-word ;
: <foo/> [ "<" % % "/>" % ] "" make ;
: def-for-html-word-<foo/> ( name -- )
#! Return the name and code for the <foo/> patterned
#! word.
dup <foo/> swap [ <foo/> write-html ] curry html-word ;
dup <foo/> swap [ <foo/> 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-<foo>
@ -114,7 +117,7 @@ SYMBOL: html
dup def-for-html-word-foo>
def-for-html-word-</foo> ;
: 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-<foo/>
@ -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

8
extra/html/html-tests.factor
View File

@ -54,10 +54,16 @@ M: funky browser-link-href
] make-html-string
] unit-test
[ "<div style='background-color: #ff00ff; '>cdr</div>" ]
[ "<div style='background-color: #ff00ff; white-space: pre; font-family: monospace; '>cdr</div>" ]
[
[
H{ { page-color { 1 0 1 1 } } }
[ "cdr" write ] with-nesting
] make-html-string
] unit-test
[
"<div style='white-space: pre; font-family: monospace; '></div>"
] [
[ H{ } [ ] with-nesting nl ] make-html-string
] unit-test

26
extra/html/html.factor
View File

@ -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
: <html-stream> ( 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 <html-sub-stream> ;
@ -164,7 +176,7 @@ M: html-stream make-block-stream ( style stream -- stream' )
html-block-stream <html-sub-stream> ;
M: html-stream stream-write-table ( grid style stream -- )
[
a-div [
<table dup table-attrs table> swap [
<tr> [
<td "top" =valign swap table-style =style td>
@ -178,7 +190,7 @@ M: html-stream make-cell-stream ( style stream -- stream' )
(html-sub-stream) ;
M: html-stream stream-nl ( stream -- )
[ <br/> ] with-stream* ;
dup test-last-div? [ drop ] [ [ <br/> ] with-stream* ] if ;
! Utilities
: with-html-stream ( quot -- )

4
extra/http/server/responders/responders.factor
View File

@ -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 ;

4
extra/http/server/server.factor
View File

@ -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 ;

3
extra/http/server/templating/templating.factor
View File

@ -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 -- )

4
extra/io/server/server-tests.factor Normal file
View File

@ -0,0 +1,4 @@
IN: temporary
USING: tools.test.inference io.server ;
{ 1 0 } [ [ ] spawn-server ] unit-test-effect

3
extra/io/server/server.factor
View File

@ -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 )

2
extra/io/windows/ce/ce.factor
View File

@ -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

0
extra/math/text/authors.txt → extra/math/text/english/authors.txt
View File

2
extra/math/text/text-docs.factor → extra/math/text/english/english-docs.factor
View File

@ -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 } }

2
extra/math/text/text-tests.factor → extra/math/text/english/english-tests.factor
View File

@ -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

8
extra/math/text/text.factor → extra/math/text/english/english.factor
View File

@ -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
<PRIVATE
@ -26,10 +26,7 @@ IN: math.text
SYMBOL: and-needed?
: set-conjunction ( seq -- )
first {
[ dup 100 < ]
[ dup 0 > ]
} && 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 ;

1
extra/math/text/english/summary.txt Normal file
View File

@ -0,0 +1 @@
Convert integers to English text

1
extra/math/text/summary.txt
View File

@ -1 +0,0 @@
Convert integers to text

2
extra/porter-stemmer/porter-stemmer-tests.factor
View File

@ -56,7 +56,7 @@ io.files ;
[ "hell" ] [ "hell" step5 "" like ] unit-test
[ "mate" ] [ "mate" step5 "" like ] unit-test
: resource-lines resource-path <file-reader> lines ;
: resource-lines resource-path file-lines ;
[ { } ] [
"extra/porter-stemmer/test/voc.txt" resource-lines

14
extra/project-euler/002/002.factor
View File

@ -19,14 +19,18 @@ IN: project-euler.002
! SOLUTION
! --------
: last2 ( seq -- elt last )
reverse first2 swap ;
<PRIVATE
: fib-up-to ( n -- seq )
{ 0 } 1 [ pick dupd < ] [ add dup last2 + ] [ ] while drop nip ;
: (fib-upto) ( seq n limit -- seq )
2dup <= [ >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

9
extra/project-euler/003/003.factor
View File

@ -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

6
extra/project-euler/004/004.factor
View File

@ -26,14 +26,16 @@ IN: project-euler.004
<PRIVATE
: source-004 ( -- seq )
100 999 [a,b] [ 10 mod zero? not ] subset ;
: max-palindrome ( seq -- palindrome )
natural-sort [ palindrome? ] find-last nip ;
PRIVATE>
: 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

2
extra/project-euler/005/005.factor
View File

@ -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

8
extra/project-euler/007/007.factor
View File

@ -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

2
extra/project-euler/008/008.factor
View File

@ -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

14
extra/project-euler/009/009.factor
View File

@ -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 ;

2
extra/project-euler/010/010.factor
View File

@ -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

2
extra/project-euler/012/012.factor
View File

@ -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

2
extra/project-euler/013/013.factor
View File

@ -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

11
extra/project-euler/014/014.factor
View File

@ -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>
<PRIVATE
: worth-calculating? ( n -- ? )
{
[ dup 1- 3 mod zero? ]
[ dup 1- 3 / even? ]
} && nip ;
{ [ dup 1- 3 mod zero? ] [ dup 1- 3 / even? ] } && nip ;
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

2
extra/project-euler/016/016.factor
View File

@ -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

52
extra/project-euler/017/017.factor
View File

@ -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
! --------
<PRIVATE
: units ( n -- )
{
"zero" "one" "two" "three" "four" "five" "six" "seven" "eight" "nine"
"ten" "eleven" "twelve" "thirteen" "fourteen" "fifteen" "sixteen"
"seventeen" "eighteen" "nineteen"
} nth % ;
: tenths ( n -- )
{
f f "twenty" "thirty" "fourty" "fifty" "sixty" "seventy" "eighty" "ninety"
} nth % ;
DEFER: make-english
: maybe-add ( n sep -- )
over zero? [ 2drop ] [ % make-english ] if ;
: 0-99 ( n -- )
dup 20 < [ units ] [ 10 /mod swap tenths "-" maybe-add ] if ;
: 0-999 ( n -- )
100 /mod swap
dup zero? [ drop 0-99 ] [ units " hundred" % " and " maybe-add ] if ;
: make-english ( n -- )
1000 /mod swap
dup zero? [ drop 0-999 ] [ 0-999 " thousand" % " and " maybe-add ] if ;
PRIVATE>
: >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

72
extra/project-euler/018/018.factor
View File

@ -50,39 +50,28 @@ IN: project-euler.018
<PRIVATE
: pyramid ( -- seq )
{
75
95 64
17 47 82
18 35 87 10
20 04 82 47 65
19 01 23 75 03 34
88 02 77 73 07 63 67
99 65 04 28 06 16 70 92
41 41 26 56 83 40 80 70 33
41 48 72 33 47 32 37 16 94 29
53 71 44 65 25 43 91 52 97 51 14
70 11 33 28 77 73 17 78 39 68 17 57
91 71 52 38 17 14 91 43 58 50 27 29 48
63 66 04 68 89 53 67 30 73 16 69 87 40 31
04 62 98 27 23 09 70 98 73 93 38 53 60 04 23
}
15 [ 1+ cut swap ] map nip ;
: source-018 ( -- triangle )
{ 75
95 64
17 47 82
18 35 87 10
20 04 82 47 65
19 01 23 75 03 34
88 02 77 73 07 63 67
99 65 04 28 06 16 70 92
41 41 26 56 83 40 80 70 33
41 48 72 33 47 32 37 16 94 29
53 71 44 65 25 43 91 52 97 51 14
70 11 33 28 77 73 17 78 39 68 17 57
91 71 52 38 17 14 91 43 58 50 27 29 48
63 66 04 68 89 53 67 30 73 16 69 87 40 31
04 62 98 27 23 09 70 98 73 93 38 53 60 04 23
} 15 [ 1+ cut swap ] map nip ;
PRIVATE>
! 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
! -------------------
<PRIVATE
: source-018a ( -- triangle )
{ { 75 }
{ 95 64 }
{ 17 47 82 }
{ 18 35 87 10 }
{ 20 04 82 47 65 }
{ 19 01 23 75 03 34 }
{ 88 02 77 73 07 63 67 }
{ 99 65 04 28 06 16 70 92 }
{ 41 41 26 56 83 40 80 70 33 }
{ 41 48 72 33 47 32 37 16 94 29 }
{ 53 71 44 65 25 43 91 52 97 51 14 }
{ 70 11 33 28 77 73 17 78 39 68 17 57 }
{ 91 71 52 38 17 14 91 43 58 50 27 29 48 }
{ 63 66 04 68 89 53 67 30 73 16 69 87 40 31 }
{ 04 62 98 27 23 09 70 98 73 93 38 53 60 04 23 } } ;
PRIVATE>
: 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

7
extra/project-euler/019/019.factor
View File

@ -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

2
extra/project-euler/020/020.factor
View File

@ -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

19
extra/project-euler/022/022.factor
View File

@ -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
<PRIVATE
: (source-022) ( -- path )
[
"project-euler.022" vocab-root ?resource-path %
os "windows" = [
"\\project-euler\\022\\names.txt" %
] [
"/project-euler/022/names.txt" %
] if
] "" make ;
: source-022 ( -- seq )
(source-022) file-contents [ quotable? ] subset "," split ;
"extra/project-euler/022/names.txt" resource-path
file-contents [ quotable? ] subset "," split ;
: alpha-value ( str -- n )
string>digits [ 9 - ] sigma ;
[ string>digits sum ] keep length 9 * - ;
: name-scores ( seq -- seq )
dup length [ 1+ swap alpha-value * ] 2map ;

61
extra/project-euler/023/023.factor Normal file
View File

@ -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
<PRIVATE
: source-023 ( -- seq )
46 [1,b] 47 20161 2 <range> 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

48
extra/project-euler/024/024.factor Normal file
View File

@ -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
! --------
<PRIVATE
: (>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

84
extra/project-euler/025/025.factor Normal file
View File

@ -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 ;
<PRIVATE
: (digit-fib) ( n term -- term )
2dup fib number>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
<PRIVATE
: phi ( -- phi )
5 sqrt 1+ 2 / ;
: digit-fib* ( n -- term )
1- 5 log10 2 / + phi log10 / ceiling >integer ;
PRIVATE>
: euler025a ( -- answer )
1000 digit-fib* ;
! [ euler025a ] 100 ave-time
! 0 ms run / 0 ms GC ave time - 100 trials
MAIN: euler025a

34
extra/project-euler/067/067.factor
View File

@ -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
<PRIVATE
: pyramid ( -- seq )
"resource:extra/project-euler/067/triangle.txt" ?resource-path
<file-reader> 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
! -------------------
<PRIVATE
: (source-067a) ( -- path )
[
"project-euler.067" vocab-root ?resource-path %
os "windows" = [
"\\project-euler\\067\\triangle.txt" %
] [
"/project-euler/067/triangle.txt" %
] if
] "" make ;
: source-067a ( -- triangle )
(source-067a) <file-reader> 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

30
extra/project-euler/134/134.factor
View File

@ -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
<PRIVATE
! Compute S for a given pair (p1, p2) -- that is the smallest positive
! number such that X = p1 [npt] and X = 0 [p2] (npt being the smallest
! power of 10 above p1)
: s ( p1 p2 -- s )
over 0 2array rot next-power-of-10 rot 2array chinese-remainder ;
over 0 2array rot next-power-of-10 rot 2array chinese-remainder ;
PRIVATE>
: 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

21
extra/project-euler/169/169.factor
View File

@ -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

28
extra/project-euler/173/173.factor
View File

@ -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 ;
<PRIVATE
: laminae ( upper -- n )
4 / dup sqrt [1,b] 0 rot [ over /i - - ] curry reduce ;
PRIVATE>
: euler173 ( -- answer )
1000000 laminaes ;
1000000 laminae ;
! [ euler173 ] 100 ave-time
! 0 ms run / 0 ms GC ave time - 100 trials

46
extra/project-euler/175/175.factor
View File

@ -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
! --------
<PRIVATE
: add-bits ( vec n b -- )
over zero? [
3drop
] [
pick length 1 bitand = [ over pop + ] when swap push
] if ;
over zero? [
3drop
] [
pick length 1 bitand = [ over pop + ] when swap push
] if ;
: compute ( vec ratio -- )
{
{ [ 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 ;
{
{ [ 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

77
extra/project-euler/common/common.factor
View File

@ -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? ;
<PRIVATE
: count-shifts ( seq width -- n )
>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 * ;

4
extra/project-euler/project-euler.factor
View File

@ -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
<PRIVATE

3
extra/sequences/deep/deep-docs.factor
View File

@ -1,4 +1,5 @@
USING: help.syntax help.markup sequences.deep ;
USING: help.syntax help.markup ;
IN: sequences.deep
HELP: deep-each
{ $values { "obj" "an object" } { "quot" "a quotation ( elt -- ) " } }

4
extra/tools/deploy/macosx/macosx.factor
View File

@ -3,7 +3,7 @@
USING: io io.files io.launcher kernel namespaces sequences
system tools.deploy.backend tools.deploy.config assocs
hashtables prettyprint io.unix.backend cocoa
cocoa.application cocoa.classes qualified ;
cocoa.application cocoa.classes cocoa.plists qualified ;
QUALIFIED: unix
IN: tools.deploy.macosx
@ -43,7 +43,7 @@ IN: tools.deploy.macosx
dup "CFBundleExecutable" set
"org.factor." swap append "CFBundleIdentifier" set
] H{ } make-assoc drop ; ! print-plist ;
] H{ } make-assoc print-plist ;
: create-app-plist ( vocab bundle-name -- )
dup "Contents/Info.plist" path+ <file-writer>

15
extra/ui/freetype/freetype.factor
View File

@ -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
<void*> [ FT_New_Memory_Face freetype-error ] keep *void* ;
: open-face ( font style -- face )
ttf-name ttf-path >r freetype r>
0 f <void*> [ FT_New_Face freetype-error ] keep *void* ;
ttf-name ttf-path dup file-length
<mapped-file> (open-face) ;
: dpi 72 ; inline

16
extra/unicode/breaks/breaks.factor
View File

@ -30,10 +30,9 @@ CATEGORY: grapheme-control Zl Zp Cc Cf ;
concat >set ;
: other-extend-lines ( -- lines )
"extra/unicode/PropList.txt" resource-path <file-reader> 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

2
extra/unicode/categories/categories-tests.factor
View File

@ -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

36
extra/unicode/data/data.factor
View File

@ -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

6
extra/unicode/normalize/normalize.factor
View File

@ -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

4
extra/unicode/syntax/syntax.factor
View File

@ -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 )
[

4
extra/webapps/cgi/cgi.factor
View File

@ -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

3
extra/webapps/planet/planet.factor
View File

@ -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/" }

2
extra/xml/utilities/utilities.factor
View File

@ -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

3
extra/xml/xml-docs.factor
View File

@ -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" } }