Merge git://factorcode.org/git/factor
Conflicts: extra/html/elements/elements.factordb4
Doug Coleman
commit
1a2ca6e463
|
|
@ -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 ( -- )
|
||||
|
|
|
|||
|
|
@ -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* ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
@ -229,16 +229,6 @@ M: timestamp <=> ( ts1 ts2 -- n )
|
|||
[ 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 ;
|
||||
|
||||
|
||||
|
||||
: gmt ( -- timestamp )
|
||||
#! GMT time, right now
|
||||
|
|
@ -382,23 +372,6 @@ M: timestamp <=> ( ts1 ts2 -- n )
|
|||
: 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" ] }
|
||||
|
|
|
|||
|
|
@ -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,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:
|
||||
|
|
|
|||
|
|
@ -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" } }
|
||||
|
|
|
|||
|
|
@ -157,6 +157,8 @@ C-STRUCT: face
|
|||
|
||||
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 ) ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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&o'>" ]
|
||||
[ [ <a "h&o" =href a> ] make-html-string ] unit-test
|
||||
|
|
@ -4,7 +4,7 @@
|
|||
! 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
|
||||
|
||||
|
|
@ -57,54 +57,57 @@ 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 ;
|
||||
</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 ;
|
||||
foo/> [ "/>" write-html ] empty-effect html-word ;
|
||||
|
||||
: define-closed-html-word ( name -- )
|
||||
#! Given an HTML tag name, define the words for
|
||||
|
|
@ -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
|
||||
[
|
||||
! 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-closed-html-word ] each
|
||||
|
||||
! Define some open HTML tags
|
||||
[
|
||||
! Define some open HTML tags
|
||||
[
|
||||
"input"
|
||||
"br"
|
||||
"link"
|
||||
"img"
|
||||
] [ define-open-html-word ] each
|
||||
] [ define-open-html-word ] each
|
||||
|
||||
! Define some attributes
|
||||
[
|
||||
! 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-attribute-word ] each
|
||||
] with-compilation-unit
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -0,0 +1,4 @@
|
|||
IN: temporary
|
||||
USING: tools.test.inference io.server ;
|
||||
|
||||
{ 1 0 } [ [ ] spawn-server ] unit-test-effect
|
||||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 } }
|
||||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
Convert integers to English text
|
||||
|
|
@ -1 +0,0 @@
|
|||
Convert integers to text
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -18,12 +18,12 @@ IN: project-euler.007
|
|||
! --------
|
||||
|
||||
: nth-prime ( n -- n )
|
||||
1 - lprimes lnth ;
|
||||
1- lprimes lnth ;
|
||||
|
||||
: euler007 ( -- answer )
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
[ 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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -50,9 +50,8 @@ IN: project-euler.018
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: pyramid ( -- seq )
|
||||
{
|
||||
75
|
||||
: source-018 ( -- triangle )
|
||||
{ 75
|
||||
95 64
|
||||
17 47 82
|
||||
18 35 87 10
|
||||
|
|
@ -67,22 +66,12 @@ IN: project-euler.018
|
|||
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 ;
|
||||
} 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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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,23 +9,26 @@ 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
|
||||
|
|
@ -33,10 +36,13 @@ IN: project-euler.134
|
|||
: s ( p1 p2 -- s )
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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,6 +22,7 @@ USING: combinators kernel math math.functions memoize ;
|
|||
|
||||
! What is f(1025)?
|
||||
|
||||
|
||||
! SOLUTION
|
||||
! --------
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -8,29 +8,31 @@ 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
|
||||
|
|
@ -45,6 +47,8 @@ IN: project-euler.175
|
|||
{ [ t ] [ [ 1 mod compute ] 2keep >integer 0 add-bits ] }
|
||||
} cond ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: euler175 ( -- result )
|
||||
V{ 1 } clone dup 123456789/987654321 compute [ number>string ] map "," join ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 * ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 -- ) " } }
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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/" }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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" } }
|
||||
|
|
|
|||
Loading…
Reference in New Issue