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

Merge branch 'master' of git://factorcode.org/git/factor into clean-linux-x86-32

db4
Maxim Savchenko 2009-04-08 07:13:30 -04:00
parent 5d14559049 30191f87e5
commit 41f188ee9b
33 changed files with 1268 additions and 1181 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
basis/alien/fortran/fortran.factor
View File

@ -8,7 +8,7 @@ io.encodings.ascii io.encodings.string shuffle effects math.ranges
math.order sorting strings system alien.libraries ;
IN: alien.fortran
SINGLETONS: f2c-abi gfortran-abi intel-unix-abi intel-windows-abi ;
SINGLETONS: f2c-abi g95-abi gfortran-abi intel-unix-abi intel-windows-abi ;
<<
: add-f2c-libraries ( -- )
@ -42,30 +42,35 @@ library-fortran-abis [ H{ } clone ] initialize
HOOK: fortran-c-abi fortran-abi ( -- abi )
M: f2c-abi fortran-c-abi "cdecl" ;
M: g95-abi fortran-c-abi "cdecl" ;
M: gfortran-abi fortran-c-abi "cdecl" ;
M: intel-unix-abi fortran-c-abi "cdecl" ;
M: intel-windows-abi fortran-c-abi "cdecl" ;
HOOK: real-functions-return-double? fortran-abi ( -- ? )
M: f2c-abi real-functions-return-double? t ;
M: g95-abi real-functions-return-double? f ;
M: gfortran-abi real-functions-return-double? f ;
M: intel-unix-abi real-functions-return-double? f ;
M: intel-windows-abi real-functions-return-double? f ;
HOOK: complex-functions-return-by-value? fortran-abi ( -- ? )
M: f2c-abi complex-functions-return-by-value? f ;
M: g95-abi complex-functions-return-by-value? f ;
M: gfortran-abi complex-functions-return-by-value? t ;
M: intel-unix-abi complex-functions-return-by-value? f ;
M: intel-windows-abi complex-functions-return-by-value? f ;
HOOK: character(1)-maps-to-char? fortran-abi ( -- ? )
M: f2c-abi character(1)-maps-to-char? f ;
M: g95-abi character(1)-maps-to-char? f ;
M: gfortran-abi character(1)-maps-to-char? f ;
M: intel-unix-abi character(1)-maps-to-char? t ;
M: intel-windows-abi character(1)-maps-to-char? t ;
HOOK: mangle-name fortran-abi ( name -- name' )
M: f2c-abi mangle-name lowercase-name-with-extra-underscore ;
M: g95-abi mangle-name lowercase-name-with-extra-underscore ;
M: gfortran-abi mangle-name lowercase-name-with-underscore ;
M: intel-unix-abi mangle-name lowercase-name-with-underscore ;
M: intel-windows-abi mangle-name >upper ;

1
basis/command-line/command-line.factor
View File

@ -60,7 +60,6 @@ SYMBOL: main-vocab-hook
: default-cli-args ( -- )
global [
"quiet" off
"script" off
"e" off
"user-init" on
embedded? "quiet" set

9
basis/http/client/client.factor
View File

@ -6,7 +6,7 @@ math.order hashtables byte-arrays destructors
io io.sockets io.streams.string io.files io.timeouts
io.pathnames io.encodings io.encodings.string io.encodings.ascii
io.encodings.utf8 io.encodings.8-bit io.encodings.binary io.crlf
io.streams.duplex fry ascii urls urls.encoding present
io.streams.duplex fry ascii urls urls.encoding present locals
http http.parsers http.client.post-data ;
IN: http.client
@ -77,12 +77,13 @@ SYMBOL: redirects
: redirect? ( response -- ? )
code>> 300 399 between? ;
: do-redirect ( quot: ( chunk -- ) response -- response )
:: do-redirect ( quot: ( chunk -- ) response -- response )
redirects inc
redirects get max-redirects < [
request get clone
swap "location" header redirect-url
"GET" >>method swap (with-http-request)
response "location" header redirect-url
response code>> 307 = [ "GET" >>method ] unless
quot (with-http-request)
] [ too-many-redirects ] if ; inline recursive
: read-chunk-size ( -- n )

43
basis/http/http-tests.factor
View File

@ -1,8 +1,8 @@
USING: http http.server http.client http.client.private tools.test multiline
io.streams.string io.encodings.utf8 io.encodings.8-bit
io.encodings.binary io.encodings.string kernel arrays splitting
sequences assocs io.sockets db db.sqlite continuations urls
hashtables accessors namespaces xml.data ;
USING: http http.server http.client http.client.private tools.test
multiline io.streams.string io.encodings.utf8 io.encodings.8-bit
io.encodings.binary io.encodings.string io.encodings.ascii kernel
arrays splitting sequences assocs io.sockets db db.sqlite
continuations urls hashtables accessors namespaces xml.data ;
IN: http.tests
[ "text/plain" latin1 ] [ "text/plain" parse-content-type ] unit-test
@ -359,4 +359,37 @@ SYMBOL: a
! Test basic auth
[ "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" ] [ <request> "Aladdin" "open sesame" set-basic-auth "Authorization" header ] unit-test
! Test a corner case with static responder
[ ] [
<dispatcher>
add-quit-action
"vocab:http/test/foo.html" <static> >>default
test-httpd
] unit-test
[ t ] [
"http://localhost/" add-port http-get nip
"vocab:http/test/foo.html" ascii file-contents =
] unit-test
[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test
! Check behavior of 307 redirect (reported by Chris Double)
[ ] [
<dispatcher>
add-quit-action
<action>
[ "b" <temporary-redirect> ] >>submit
"a" add-responder
<action>
[
request get post-data>> data>> "data" =
[ "OK" "text/plain" <content> ] [ "OOPS" throw ] if
] >>submit
"b" add-responder
test-httpd
] unit-test
[ "OK" ] [ "data" "http://localhost/a" add-port http-post nip ] unit-test
[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test

4
basis/http/server/static/static.factor
View File

@ -47,8 +47,8 @@ TUPLE: file-responder root hook special allow-listings ;
if ;
: serving-path ( filename -- filename )
[ file-responder get root>> trim-tail-separators "/" ] dip
"" or trim-head-separators 3append ;
[ file-responder get root>> trim-tail-separators ] dip
[ "/" swap trim-head-separators 3append ] unless-empty ;
: serve-file ( filename -- response )
dup mime-type

6
basis/io/streams/limited/limited-tests.factor
View File

@ -76,3 +76,9 @@ IN: io.streams.limited.tests
[ decoder? ] both?
] with-destructors
] unit-test
[ "HELL" ] [
"HELLO"
[ f stream-throws limit-input 4 read ]
with-string-reader
] unit-test

8
basis/io/streams/limited/limited.factor
View File

@ -22,7 +22,7 @@ M: decoder limit ( stream limit mode -- stream' )
[ clone ] 2dip '[ _ _ limit ] change-stream ;
M: object limit ( stream limit mode -- stream' )
<limited-stream> ;
over [ <limited-stream> ] [ 2drop ] if ;
GENERIC: unlimited ( stream -- stream' )
@ -32,9 +32,11 @@ M: decoder unlimited ( stream -- stream' )
M: object unlimited ( stream -- stream' )
stream>> stream>> ;
: limit-input ( limit mode -- ) input-stream [ -rot limit ] change ;
: limit-input ( limit mode -- )
[ input-stream ] 2dip '[ _ _ limit ] change ;
: unlimited-input ( -- ) input-stream [ unlimited ] change ;
: unlimited-input ( -- )
input-stream [ unlimited ] change ;
: with-unlimited-stream ( stream quot -- )
[ clone unlimited ] dip call ; inline

1
basis/math/blas/config/config.factor
View File

@ -15,6 +15,7 @@ blas-fortran-abi [
{
{ [ os macosx? ] [ intel-unix-abi ] }
{ [ os windows? cpu x86.32? and ] [ f2c-abi ] }
{ [ os netbsd? cpu x86.64? and ] [ g95-abi ] }
{ [ os windows? cpu x86.64? and ] [ gfortran-abi ] }
{ [ os freebsd? ] [ gfortran-abi ] }
{ [ os linux? cpu x86.32? and ] [ gfortran-abi ] }

13
basis/opengl/textures/textures.factor
View File

@ -3,9 +3,11 @@
USING: accessors assocs cache colors.constants destructors fry kernel
opengl opengl.gl combinators images images.tesselation grouping
specialized-arrays.float sequences math math.vectors
math.matrices generalizations fry arrays ;
math.matrices generalizations fry arrays namespaces ;
IN: opengl.textures
SYMBOL: non-power-of-2-textures?
: gen-texture ( -- id ) [ glGenTextures ] (gen-gl-object) ;
: delete-texture ( id -- ) [ glDeleteTextures ] (delete-gl-object) ;
@ -29,9 +31,14 @@ GENERIC: draw-scaled-texture ( dim texture -- )
TUPLE: single-texture image dim loc texture-coords texture display-list disposed ;
: adjust-texture-dim ( dim -- dim' )
non-power-of-2-textures? get [
[ next-power-of-2 ] map
] unless ;
: (tex-image) ( image -- )
[ GL_TEXTURE_2D 0 GL_RGBA ] dip
[ dim>> first2 [ next-power-of-2 ] bi@ 0 ]
[ dim>> adjust-texture-dim first2 0 ]
[ component-order>> component-order>format f ] bi
glTexImage2D ;
@ -81,7 +88,7 @@ TUPLE: single-texture image dim loc texture-coords texture display-list disposed
] with-texturing ;
: texture-coords ( texture -- coords )
[ [ dim>> ] [ image>> dim>> [ next-power-of-2 ] map ] bi v/ ]
[ [ dim>> ] [ image>> dim>> adjust-texture-dim ] bi v/ ]
[
image>> upside-down?>>
{ { 0 1 } { 1 1 } { 1 0 } { 0 0 } }

4
basis/tools/deploy/backend/backend.factor
View File

@ -8,7 +8,7 @@ debugger io.streams.c io.files io.files.temp io.pathnames
io.directories io.directories.hierarchy io.backend quotations
io.launcher words.private tools.deploy.config
tools.deploy.config.editor bootstrap.image io.encodings.utf8
destructors accessors ;
destructors accessors hashtables ;
IN: tools.deploy.backend
: copy-vm ( executable bundle-name -- vm )
@ -88,7 +88,7 @@ DEFER: ?make-staging-image
[ drop ] [ make-staging-image ] if ;
: make-deploy-config ( vocab -- file )
[ deploy-config unparse-use ]
[ deploy-config vocab-roots get vocab-roots associate assoc-union unparse-use ]
[ "deploy-config-" prepend temp-file ] bi
[ utf8 set-file-contents ] keep ;

8
basis/ui/backend/backend.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces opengl opengl.gl ;
USING: kernel namespaces opengl opengl.gl fry ;
IN: ui.backend
SYMBOL: ui-backend
@ -28,7 +28,7 @@ GENERIC: flush-gl-context ( handle -- )
HOOK: offscreen-pixels ui-backend ( world -- alien w h )
: with-gl-context ( handle quot -- )
swap [ select-gl-context call ] keep
flush-gl-context gl-error ; inline
'[ select-gl-context @ ]
[ flush-gl-context gl-error ] bi ; inline
HOOK: (with-ui) ui-backend ( quot -- )

2
basis/ui/gadgets/buttons/buttons-docs.factor
View File

@ -26,7 +26,7 @@ HELP: <repeat-button>
{ $description "Creates a new " { $link button } " derived from a " { $link <border-button> } " which calls the quotation every 100 milliseconds as long as the mouse button is held down." } ;
HELP: button-pen
{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " gneeric words by delegating to an object in one of four slots which depend on the state of the button being drawn:"
{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words by delegating to an object in one of four slots which depend on the state of the button being drawn:"
{ $list
{ { $snippet "plain" } " - the button is inactive" }
{ { $snippet "rollover" } " - the button is under the mouse" }

12
basis/ui/gadgets/worlds/worlds.factor
View File

@ -1,9 +1,10 @@
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs continuations kernel math models
namespaces opengl sequences io combinators combinators.short-circuit
fry math.vectors math.rectangles cache ui.gadgets ui.gestures
ui.render ui.backend ui.gadgets.tracks ui.commands ;
namespaces opengl opengl.capabilities opengl.textures sequences io
combinators combinators.short-circuit fry math.vectors math.rectangles
cache ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
ui.commands ;
IN: ui.gadgets.worlds
TUPLE: world < track
@ -76,8 +77,13 @@ SYMBOL: flush-layout-cache-hook
flush-layout-cache-hook [ [ ] ] initialize
: check-extensions ( -- )
"2.0" { "GL_ARB_texture_non_power_of_two" } has-gl-version-or-extensions?
non-power-of-2-textures? set ;
: (draw-world) ( world -- )
dup handle>> [
check-extensions
{
[ init-gl ]
[ draw-gadget ]

31
basis/ui/ui.factor
View File

@ -2,9 +2,9 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs io kernel math models namespaces make dlists
deques sequences threads sequences words continuations init
combinators hashtables concurrency.flags sets accessors calendar fry
destructors ui.gadgets ui.gadgets.private ui.gadgets.worlds
ui.gadgets.tracks ui.gestures ui.backend ui.render ;
combinators combinators.short-circuit hashtables concurrency.flags
sets accessors calendar fry destructors ui.gadgets ui.gadgets.private
ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render ;
IN: ui
<PRIVATE
@ -117,12 +117,10 @@ M: world ungraft*
gesture-queue [ send-queued-gesture notify-queued ] slurp-deque ;
: update-ui ( -- )
[
notify-queued
layout-queued
redraw-worlds
send-queued-gestures
] [ ui-error ] recover ;
notify-queued
layout-queued
redraw-worlds
send-queued-gestures ;
SYMBOL: ui-thread
@ -133,8 +131,7 @@ SYMBOL: ui-thread
PRIVATE>
: find-window ( quot -- world )
windows get values
[ gadget-child swap call ] with find-last nip ; inline
[ windows get values ] dip '[ gadget-child @ ] find-last nip ; inline
: ui-running? ( -- ? )
\ ui-running get-global ;
@ -142,9 +139,15 @@ PRIVATE>
<PRIVATE
: update-ui-loop ( -- )
[ ui-running? ui-thread get-global self eq? and ]
[ ui-notify-flag get lower-flag update-ui ]
while ;
#! Note the logic: if update-ui fails, we open an error window
#! and run one iteration of update-ui. If that also fails, well,
#! the whole UI subsystem is broken so we exit out of the
#! update-ui-loop.
[ { [ ui-running? ] [ ui-thread get-global self eq? ] } 0&& ]
[
ui-notify-flag get lower-flag
[ update-ui ] [ ui-error update-ui ] recover
] while ;
: start-ui-thread ( -- )
[ self ui-thread set-global update-ui-loop ]

22
extra/descriptive/descriptive-docs.factor
View File

@ -1,20 +1,28 @@
USING: help.syntax help.markup ;
USING: help.syntax help.markup words ;
IN: descriptive
HELP: DESCRIPTIVE:
{ $syntax "DESCRIPTIVE: word ( inputs -- outputs ) definition ;" }
{ $description "Defines a word such that, if an error is thrown from within it, that error is wrapped in a descriptive tag including the arguments to that word." } ;
{ $description "Defines a word such that, if an error is thrown from within it, that error is wrapped in a " { $link descriptive-error } " with the arguments to that word." } ;
HELP: DESCRIPTIVE::
{ $syntax "DESCRIPTIVE:: word ( inputs -- outputs ) definition ;" }
{ $description "Defines a word which uses locals such that, if an error is thrown from within it, that error is wrapped in a descriptive tag including the arguments to that word." } ;
{ $description "Defines a word which uses locals such that, if an error is thrown from within it, that error is wrapped in a " { $link descriptive-error } " with the arguments to that word." } ;
HELP: descriptive
{ $class-description "The class of errors wrapping another error (in the underlying slot) which were thrown in a word (in the word slot) with a given set of arguments (in the args slot)." } ;
HELP: descriptive-error
{ $error-description "The class of errors wrapping another error (in the underlying slot) which were thrown in a word (in the word slot) with a given set of arguments (in the args slot)." } ;
HELP: make-descriptive
{ $values { "word" word } }
{ $description "Makes the word wrap errors in " { $link descriptive-error } " instances." } ;
ARTICLE: "descriptive" "Descriptive errors"
"This vocabulary defines automatic descriptive errors. Using it, you can define a word which acts as normal, except when it throws an error, the error is wrapped in a special descriptor declaring that an error was thrown from inside that word, and including the arguments given to that word. The error is of the following class:"
{ $subsection descriptive }
"This vocabulary defines automatic descriptive errors. Using it, you can define a word which acts as normal, except when it throws an error, the error is wrapped in an instance of a class:"
{ $subsection descriptive-error }
"The wrapper contains the word itself, the input parameters, as well as the original error."
$nl
"To annotate an existing word with descriptive error checking:"
{ $subsection make-descriptive }
"To define words which throw descriptive errors, use the following words:"
{ $subsection POSTPONE: DESCRIPTIVE: }
{ $subsection POSTPONE: DESCRIPTIVE:: } ;

11
extra/descriptive/descriptive.factor
View File

@ -1,6 +1,9 @@
USING: words kernel sequences locals locals.parser
! Copyright (c) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: words kernel sequences locals locals.parser fry
locals.definitions accessors parser namespaces continuations
summary definitions generalizations arrays prettyprint debugger io ;
summary definitions generalizations arrays prettyprint debugger io
effects tools.annotations ;
IN: descriptive
ERROR: descriptive-error args underlying word ;
@ -23,6 +26,10 @@ M: descriptive-error error.
PRIVATE>
: make-descriptive ( word -- )
dup [ ] [ def>> ] [ stack-effect ] tri [descriptive]
'[ drop _ ] annotate-methods ;
: define-descriptive ( word def effect -- )
[ drop "descriptive-definition" set-word-prop ]
[ [ [ dup ] 2dip [descriptive] ] keep define-declared ]

1267
extra/poker/arrays/arrays.factor
View File

File diff suppressed because it is too large Load Diff

30
extra/poker/poker-docs.factor Normal file
View File

@ -0,0 +1,30 @@
USING: help.markup help.syntax strings ;
IN: poker
HELP: <hand>
{ $values { "str" string } { "hand" "a new hand" } }
{ $description "Creates a new poker hand containing the cards specified in " { $snippet "str" } "." }
{ $examples
{ $example "USING: kernel math.order poker prettyprint ;"
"\"AC KC QC JC TC\" \"7C 6D 5H 4S 2C\" [ <hand> ] bi@ <=> ." "+lt+" }
{ $example "USING: kernel poker prettyprint ;"
"\"TC 9C 8C 7C 6C\" \"TH 9H 8H 7H 6H\" [ <hand> ] bi@ = ." "t" }
}
{ $notes "Cards may be specified in any order. Hands are directly comparable to each other on the basis of their computed value. Two hands are considered equal when they would tie in a game (despite being composed of different cards)." } ;
HELP: >cards
{ $values { "hand" "a hand" } { "str" string } }
{ $description "Outputs a string representation of a hand's cards." }
{ $examples
{ $example "USING: poker prettyprint ;"
"\"AC KC QC JC TC\" <hand> >cards ." "\"AC KC QC JC TC\"" }
} ;
HELP: >value
{ $values { "hand" "a hand" } { "str" string } }
{ $description "Outputs a string representation of a hand's value." }
{ $examples
{ $example "USING: poker prettyprint ;"
"\"AC KC QC JC TC\" <hand> >value ." "\"Straight Flush\"" }
}
{ $notes "This should not be used as a basis for hand comparison." } ;

16
extra/poker/poker-tests.factor
View File

@ -1,16 +1,28 @@
USING: accessors poker poker.private tools.test ;
USING: accessors poker poker.private tools.test math.order kernel ;
IN: poker.tests
[ 134236965 ] [ "KD" >ckf ] unit-test
[ 529159 ] [ "5s" >ckf ] unit-test
[ 33589533 ] [ "jc" >ckf ] unit-test
[ 7462 ] [ "7C 5D 4H 3S 2C" <hand> value>> ] unit-test
[ 1601 ] [ "KD QS JC TH 9S" <hand> value>> ] unit-test
[ 11 ] [ "AC AD AH AS KC" <hand> value>> ] unit-test
[ 9 ] [ "6C 5C 4C 3C 2C" <hand> value>> ] unit-test
[ 1 ] [ "AC KC QC JC TC" <hand> value>> ] unit-test
[ "High Card" ] [ "7C 5D 4H 3S 2C" <hand> >value ] unit-test
[ "Straight" ] [ "KD QS JC TH 9S" <hand> >value ] unit-test
[ "Four of a Kind" ] [ "AC AD AH AS KC" <hand> >value ] unit-test
[ "Straight Flush" ] [ "6C 5C 4C 3C 2C" <hand> >value ] unit-test
[ "6C 5C 4C 3C 2C" ] [ "6C 5C 4C 3C 2C" <hand> >cards ] unit-test
[ +gt+ ] [ "7C 5D 4H 3S 2C" "KD QS JC TH 9S" [ <hand> ] bi@ <=> ] unit-test
[ +lt+ ] [ "AC AD AH AS KC" "KD QS JC TH 9S" [ <hand> ] bi@ <=> ] unit-test
[ +eq+ ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ <hand> ] bi@ <=> ] unit-test
[ t ] [ "7C 5D 4H 3S 2C" "2C 3S 4H 5D 7C" [ <hand> ] bi@ = ] unit-test
[ t ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ <hand> ] bi@ = ] unit-test
[ f ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ <hand> ] bi@ eq? ] unit-test

52
extra/poker/poker.factor
View File

@ -4,8 +4,10 @@ USING: accessors ascii binary-search combinators kernel locals math
math.bitwise math.order poker.arrays sequences splitting ;
IN: poker
! The algorithm used is based on Cactus Kev's Poker Hand Evaluator:
! The algorithm used is based on Cactus Kev's Poker Hand Evaluator with
! the Senzee Perfect Hash Optimization:
! http://www.suffecool.net/poker/evaluator.html
! http://www.senzee5.com/2006/06/some-perfect-hash.html
<PRIVATE
@ -124,14 +126,22 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush"
: prime-bits ( cards -- q )
[ HEX: FF bitand ] map-product ;
: perfect-hash-find ( q -- value )
#! magic to convert a hand's unique identifying bits to the
#! proper index for fast lookup in a table of hand values
HEX: E91AAA35 +
dup -16 shift bitxor
dup 8 shift w+
dup -4 shift bitxor
[ -8 shift HEX: 1FF bitand adjustments-table nth ]
[ dup 2 shift w+ -19 shift ] bi
bitxor values-table nth ;
: hand-value ( cards -- value )
{
{ [ dup flush? ] [ flushes-table lookup ] }
{ [ dup unique5? ] [ unique5-table lookup ] }
[
prime-bits products-table sorted-index
values-table nth
]
[ prime-bits perfect-hash-find ]
} cond ;
: >card-rank ( card -- str )
@ -145,6 +155,19 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush"
[ drop "S" ]
} cond ;
: hand-rank ( hand -- rank )
value>> {
{ [ dup 6185 > ] [ drop HIGH_CARD ] } ! 1277 high card
{ [ dup 3325 > ] [ drop ONE_PAIR ] } ! 2860 one pair
{ [ dup 2467 > ] [ drop TWO_PAIR ] } ! 858 two pair
{ [ dup 1609 > ] [ drop THREE_OF_A_KIND ] } ! 858 three-kind
{ [ dup 1599 > ] [ drop STRAIGHT ] } ! 10 straights
{ [ dup 322 > ] [ drop FLUSH ] } ! 1277 flushes
{ [ dup 166 > ] [ drop FULL_HOUSE ] } ! 156 full house
{ [ dup 10 > ] [ drop FOUR_OF_A_KIND ] } ! 156 four-kind
[ drop STRAIGHT_FLUSH ] ! 10 straight-flushes
} cond ;
PRIVATE>
TUPLE: hand
@ -159,23 +182,10 @@ M: hand equal?
" " split [ >ckf ] map
dup hand-value hand boa ;
: hand-rank ( hand -- rank )
value>> {
{ [ dup 6185 > ] [ drop HIGH_CARD ] } ! 1277 high card
{ [ dup 3325 > ] [ drop ONE_PAIR ] } ! 2860 one pair
{ [ dup 2467 > ] [ drop TWO_PAIR ] } ! 858 two pair
{ [ dup 1609 > ] [ drop THREE_OF_A_KIND ] } ! 858 three-kind
{ [ dup 1599 > ] [ drop STRAIGHT ] } ! 10 straights
{ [ dup 322 > ] [ drop FLUSH ] } ! 1277 flushes
{ [ dup 166 > ] [ drop FULL_HOUSE ] } ! 156 full house
{ [ dup 10 > ] [ drop FOUR_OF_A_KIND ] } ! 156 four-kind
[ drop STRAIGHT_FLUSH ] ! 10 straight-flushes
} cond ;
: >value ( hand -- str )
hand-rank VALUE_STR nth ;
: >cards ( hand -- str )
cards>> [
[ >card-rank ] [ >card-suit ] bi append
] map " " join ;
: >value ( hand -- str )
hand-rank VALUE_STR nth ;

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

@ -17,9 +17,6 @@ IN: project-euler.007
! SOLUTION
! --------
: nth-prime ( n -- n )
1- lprimes lnth ;
: euler007 ( -- answer )
10001 nth-prime ;

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

@ -73,15 +73,12 @@ IN: project-euler.054
"resource:extra/project-euler/054/poker.txt" ascii file-lines
[ [ 14 head-slice ] [ 14 tail-slice* ] bi 2array ] map ;
: player1-win? ( hand1 hand2 -- ? )
before? ; inline
PRIVATE>
: euler054 ( -- answer )
source-054 [ [ <hand> ] map first2 player1-win? ] count ;
source-054 [ [ <hand> ] map first2 before? ] count ;
! [ euler054 ] 100 ave-time
! 36 ms ave run time - 2.71 SD (100 trials)
! 34 ms ave run time - 2.65 SD (100 trials)
SOLUTION: euler054

3
extra/project-euler/058/058-tests.factor Normal file
View File

@ -0,0 +1,3 @@
USING: project-euler.058 tools.test ;
{ 26241 } [ euler058 ] unit-test

68
extra/project-euler/058/058.factor Normal file
View File

@ -0,0 +1,68 @@
! Copyright (c) 2009 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: fry kernel math math.primes math.ranges project-euler.common sequences ;
IN: project-euler.058
! http://projecteuler.net/index.php?section=problems&id=58
! DESCRIPTION
! -----------
! Starting with 1 and solveling anticlockwise in the following way, a square
! solve with side length 7 is formed.
! 37 36 35 34 33 32 31
! 38 17 16 15 14 13 30
! 39 18 5 4 3 12 29
! 40 19 6 1 2 11 28
! 41 20 7 8 9 10 27
! 42 21 22 23 24 25 26
! 43 44 45 46 47 48 49
! It is interesting to note that the odd squares lie along the bottom right
! diagonal, but what is more interesting is that 8 out of the 13 numbers lying
! along both diagonals are prime; that is, a ratio of 8/13 ≈ 62%.
! If one complete new layer is wrapped around the solve above, a square solve
! with side length 9 will be formed. If this process is continued, what is the
! side length of the square solve for which the ratio of primes along both
! diagonals first falls below 10%?
! SOLUTION
! --------
<PRIVATE
CONSTANT: PERCENT_PRIME 0.1
! The corners of a square of side length n are:
! (n-2)² + 1(n-1)
! (n-2)² + 2(n-1)
! (n-2)² + 3(n-1)
! (n-2)² + 4(n-1) = odd squares, no need to calculate
: prime-corners ( n -- m )
3 [1,b] swap '[ _ [ 1- * ] keep 2 - sq + prime? ] count ;
: total-corners ( n -- m )
1- 2 * ; foldable
: ratio-below? ( count length -- ? )
total-corners 1+ / PERCENT_PRIME < ;
: next-layer ( count length -- count' length' )
2 + [ prime-corners + ] keep ;
: solve ( count length -- length )
2dup ratio-below? [ nip ] [ next-layer solve ] if ;
PRIVATE>
: euler058 ( -- answer )
8 7 solve ;
! [ euler058 ] 10 ave-time
! 12974 ms ave run time - 284.46 SD (10 trials)
SOLUTION: euler058

3
extra/project-euler/063/063-tests.factor Normal file
View File

@ -0,0 +1,3 @@
USING: project-euler.063 tools.test ;
{ 49 } [ euler063 ] unit-test

37
extra/project-euler/063/063.factor Normal file
View File

@ -0,0 +1,37 @@
! Copyright (c) 2009 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions math.ranges project-euler.common sequences ;
IN: project-euler.063
! http://projecteuler.net/index.php?section=problems&id=63
! DESCRIPTION
! -----------
! The 5-digit number, 16807 = 7^5, is also a fifth power. Similarly, the
! 9-digit number, 134217728 = 8^9, is a ninth power.
! How many n-digit positive integers exist which are also an nth power?
! SOLUTION
! --------
! Only have to check from 1 to 9 because 10^n already has too many digits.
! In general, x^n has n digits when:
! 10^(n-1) <= x^n < 10^n
! ...take the left side of that equation, solve for n to see where they meet:
! n = log(10) / [ log(10) - log(x) ]
! Round down since we already know that particular value of n is no good.
: euler063 ( -- answer )
9 [1,b] [ log [ 10 log dup ] dip - /i ] sigma ;
! [ euler063 ] 100 ave-time
! 0 ms ave run time - 0.0 SD (100 trials)
SOLUTION: euler063

4
extra/project-euler/069/069-tests.factor Normal file
View File

@ -0,0 +1,4 @@
USING: project-euler.069 tools.test ;
{ 510510 } [ euler069 ] unit-test
{ 510510 } [ euler069a ] unit-test

87
extra/project-euler/069/069.factor Normal file
View File

@ -0,0 +1,87 @@
! Copyright (c) 2009 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators fry kernel math math.primes math.primes.factors math.ranges
project-euler.common sequences ;
IN: project-euler.069
! http://projecteuler.net/index.php?section=problems&id=69
! DESCRIPTION
! -----------
! Euler's Totient function, φ(n) [sometimes called the phi function], is used
! to determine the number of numbers less than n which are relatively prime to
! n. For example, as 1, 2, 4, 5, 7, and 8, are all less than nine and
! relatively prime to nine, φ(9)=6.
! +----+------------------+------+-----------+
! | n | Relatively Prime | φ(n) | n / φ(n) |
! +----+------------------+------+-----------+
! | 2 | 1 | 1 | 2 |
! | 3 | 1,2 | 2 | 1.5 |
! | 4 | 1,3 | 2 | 2 |
! | 5 | 1,2,3,4 | 4 | 1.25 |
! | 6 | 1,5 | 2 | 3 |
! | 7 | 1,2,3,4,5,6 | 6 | 1.1666... |
! | 8 | 1,3,5,7 | 4 | 2 |
! | 9 | 1,2,4,5,7,8 | 6 | 1.5 |
! | 10 | 1,3,7,9 | 4 | 2.5 |
! +----+------------------+------+-----------+
! It can be seen that n = 6 produces a maximum n / φ(n) for n ≤ 10.
! Find the value of n ≤ 1,000,000 for which n / φ(n) is a maximum.
! SOLUTION
! --------
! Brute force
<PRIVATE
: totient-ratio ( n -- m )
dup totient / ;
PRIVATE>
: euler069 ( -- answer )
2 1000000 [a,b] [ totient-ratio ] map
[ supremum ] keep index 2 + ;
! [ euler069 ] 10 ave-time
! 25210 ms ave run time - 115.37 SD (10 trials)
! ALTERNATE SOLUTIONS
! -------------------
! In order to obtain maximum n / φ(n), φ(n) needs to be low and n needs to be
! high. Hence we need a number that has the most factors. A number with the
! most unique factors would have fewer relatively prime.
<PRIVATE
: primorial ( n -- m )
{
{ [ dup 0 = ] [ drop V{ 1 } ] }
{ [ dup 1 = ] [ drop V{ 2 } ] }
[ nth-prime primes-upto ]
} cond product ;
: (primorial-upto) ( count limit -- m )
'[ dup primorial _ <= ] [ 1+ dup primorial ] produce
nip penultimate ;
: primorial-upto ( limit -- m )
1 swap (primorial-upto) ;
PRIVATE>
: euler069a ( -- answer )
1000000 primorial-upto ;
! [ euler069a ] 100 ave-time
! 0 ms ave run time - 0.01 SD (100 trials)
SOLUTION: euler069a

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

@ -32,13 +32,6 @@ IN: project-euler.071
! repeatedly until the denominator is as close to 1000000 as possible without
! going over.
<PRIVATE
: penultimate ( seq -- elt )
dup length 2 - swap nth ;
PRIVATE>
: euler071 ( -- answer )
2/5 [ dup denominator 1000000 <= ] [ 3/7 mediant dup ] produce
nip penultimate numerator ;

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

@ -1,9 +1,10 @@
! Copyright (c) 2007-2008 Aaron Schaefer.
! Copyright (c) 2007-2009 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel make math math.functions math.matrices math.miller-rabin
math.order math.parser math.primes.factors math.ranges math.ratios
sequences sorting strings unicode.case parser accessors vocabs.parser
namespaces vocabs words quotations prettyprint ;
USING: accessors arrays kernel lists make math math.functions math.matrices
math.miller-rabin math.order math.parser math.primes.factors
math.primes.lists math.ranges math.ratios namespaces parser prettyprint
quotations sequences sorting strings unicode.case vocabs vocabs.parser
words ;
IN: project-euler.common
! A collection of words used by more than one Project Euler solution
@ -16,11 +17,13 @@ IN: project-euler.common
! log10 - #25, #134
! max-path - #18, #67
! mediant - #71, #73
! nth-prime - #7, #69
! nth-triangle - #12, #42
! number>digits - #16, #20, #30, #34, #35, #38, #43, #52, #55, #56, #92
! palindrome? - #4, #36, #55
! pandigital? - #32, #38
! pentagonal? - #44, #45
! penultimate - #69, #71
! propagate-all - #18, #67
! sum-proper-divisors - #21
! tau* - #12
@ -78,6 +81,9 @@ PRIVATE>
: number-length ( n -- m )
log10 floor 1+ >integer ;
: nth-prime ( n -- n )
1- lprimes lnth ;
: nth-triangle ( n -- n )
dup 1+ * 2 / ;
@ -90,6 +96,9 @@ PRIVATE>
: pentagonal? ( n -- ? )
dup 0 > [ 24 * 1+ sqrt 1+ 6 / 1 mod zero? ] [ drop f ] if ;
: penultimate ( seq -- elt )
dup length 2 - swap nth ;
! Not strictly needed, but it is nice to be able to dump the triangle after the
! propagation
: propagate-all ( triangle -- new-triangle )

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

@ -1,4 +1,4 @@
! Copyright (c) 2007, 2008, 2009 Aaron Schaefer, Samuel Tardieu.
! Copyright (c) 2007-2009 Aaron Schaefer, Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
USING: definitions io io.files io.pathnames kernel math math.parser
prettyprint project-euler.ave-time sequences vocabs vocabs.loader
@ -15,13 +15,14 @@ USING: definitions io io.files io.pathnames kernel math math.parser
project-euler.041 project-euler.042 project-euler.043 project-euler.044
project-euler.045 project-euler.046 project-euler.047 project-euler.048
project-euler.049 project-euler.052 project-euler.053 project-euler.054
project-euler.055 project-euler.056 project-euler.057 project-euler.059
project-euler.067 project-euler.071 project-euler.073 project-euler.075
project-euler.076 project-euler.079 project-euler.092 project-euler.097
project-euler.099 project-euler.100 project-euler.116 project-euler.117
project-euler.134 project-euler.148 project-euler.150 project-euler.151
project-euler.164 project-euler.169 project-euler.173 project-euler.175
project-euler.186 project-euler.190 project-euler.203 project-euler.215 ;
project-euler.055 project-euler.056 project-euler.057 project-euler.058
project-euler.059 project-euler.063 project-euler.067 project-euler.069
project-euler.071 project-euler.073 project-euler.075 project-euler.076
project-euler.079 project-euler.092 project-euler.097 project-euler.099
project-euler.100 project-euler.116 project-euler.117 project-euler.134
project-euler.148 project-euler.150 project-euler.151 project-euler.164
project-euler.169 project-euler.173 project-euler.175 project-euler.186
project-euler.190 project-euler.203 project-euler.215 ;
IN: project-euler
<PRIVATE

645
extra/robots/robots-tests.factor
View File

@ -1,334 +1,335 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: calendar io.encodings.utf8 io.files robots tools.test ;
USING: calendar io.encodings.utf8 io.files robots tools.test
urls ;
IN: robots.tests
[
{ "http://www.chiplist.com/sitemap.txt" }
{
T{ rules
{ user-agents V{ "*" } }
{ allows V{ } }
{ disallows
V{
"/cgi-bin/"
"/scripts/"
"/ChipList2/scripts/"
"/ChipList2/styles/"
"/ads/"
"/ChipList2/ads/"
"/advertisements/"
"/ChipList2/advertisements/"
"/graphics/"
"/ChipList2/graphics/"
{ "http://www.chiplist.com/sitemap.txt" }
{
T{ rules
{ user-agents V{ "*" } }
{ allows V{ } }
{ disallows
V{
URL" /cgi-bin/"
URL" /scripts/"
URL" /ChipList2/scripts/"
URL" /ChipList2/styles/"
URL" /ads/"
URL" /ChipList2/ads/"
URL" /advertisements/"
URL" /ChipList2/advertisements/"
URL" /graphics/"
URL" /ChipList2/graphics/"
}
}
}
{ visit-time
{
T{ timestamp { hour 2 } }
T{ timestamp { hour 5 } }
{ visit-time
{
T{ timestamp { hour 2 } }
T{ timestamp { hour 5 } }
}
}
{ request-rate 1 }
{ crawl-delay 1 }
{ unknowns H{ } }
}
{ request-rate 1 }
{ crawl-delay 1 }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "UbiCrawler" } }
{ allows V{ } }
{ disallows V{ "/" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "DOC" } }
{ allows V{ } }
{ disallows V{ "/" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "Zao" } }
{ allows V{ } }
{ disallows V{ "/" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "sitecheck.internetseer.com" } }
{ allows V{ } }
{ disallows V{ "/" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "Zealbot" } }
{ allows V{ } }
{ disallows V{ "/" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "MSIECrawler" } }
{ allows V{ } }
{ disallows V{ "/" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "SiteSnagger" } }
{ allows V{ } }
{ disallows V{ "/" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "WebStripper" } }
{ allows V{ } }
{ disallows V{ "/" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "WebCopier" } }
{ allows V{ } }
{ disallows V{ "/" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "Fetch" } }
{ allows V{ } }
{ disallows V{ "/" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "Offline Explorer" } }
{ allows V{ } }
{ disallows V{ "/" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "Teleport" } }
{ allows V{ } }
{ disallows V{ "/" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "TeleportPro" } }
{ allows V{ } }
{ disallows V{ "/" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "WebZIP" } }
{ allows V{ } }
{ disallows V{ "/" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "linko" } }
{ allows V{ } }
{ disallows V{ "/" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "HTTrack" } }
{ allows V{ } }
{ disallows V{ "/" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "Microsoft.URL.Control" } }
{ allows V{ } }
{ disallows V{ "/" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "Xenu" } }
{ allows V{ } }
{ disallows V{ "/" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "larbin" } }
{ allows V{ } }
{ disallows V{ "/" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "libwww" } }
{ allows V{ } }
{ disallows V{ "/" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "ZyBORG" } }
{ allows V{ } }
{ disallows V{ "/" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "Download Ninja" } }
{ allows V{ } }
{ disallows V{ "/" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "wget" } }
{ allows V{ } }
{ disallows V{ "/" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "grub-client" } }
{ allows V{ } }
{ disallows V{ "/" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "k2spider" } }
{ allows V{ } }
{ disallows V{ "/" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "NPBot" } }
{ allows V{ } }
{ disallows V{ "/" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "WebReaper" } }
{ allows V{ } }
{ disallows V{ "/" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents
V{
"abot"
"ALeadSoftbot"
"BeijingCrawler"
"BilgiBot"
"bot"
"botlist"
"BOTW Spider"
"bumblebee"
"Bumblebee"
"BuzzRankingBot"
"Charlotte"
"Clushbot"
"Crawler"
"CydralSpider"
"DataFountains"
"DiamondBot"
"Dulance bot"
"DYNAMIC"
"EARTHCOM.info"
"EDI"
"envolk"
"Exabot"
"Exabot-Images"
"Exabot-Test"
"exactseek-pagereaper"
"Exalead NG"
"FANGCrawl"
"Feed::Find"
"flatlandbot"
"Gigabot"
"GigabotSiteSearch"
"GurujiBot"
"Hatena Antenna"
"Hatena Bookmark"
"Hatena RSS"
"HatenaScreenshot"
"Helix"
"HiddenMarket"
"HyperEstraier"
"iaskspider"
"IIITBOT"
"InfociousBot"
"iVia"
"iVia Page Fetcher"
"Jetbot"
"Kolinka Forum Search"
"KRetrieve"
"LetsCrawl.com"
"Lincoln State Web Browser"
"Links4US-Crawler"
"LOOQ"
"Lsearch/sondeur"
"MapoftheInternet.com"
"NationalDirectory"
"NetCarta_WebMapper"
"NewsGator"
"NextGenSearchBot"
"ng"
"nicebot"
"NP"
"NPBot"
"Nudelsalat"
"Nutch"
"OmniExplorer_Bot"
"OpenIntelligenceData"
"Oracle Enterprise Search"
"Pajaczek"
"panscient.com"
"PeerFactor 404 crawler"
"PeerFactor Crawler"
"PlantyNet"
"PlantyNet_WebRobot"
"plinki"
"PMAFind"
"Pogodak!"
"QuickFinder Crawler"
"Radiation Retriever"
"Reaper"
"RedCarpet"
"ScorpionBot"
"Scrubby"
"Scumbot"
"searchbot"
"Seeker.lookseek.com"
"SeznamBot"
"ShowXML"
"snap.com"
"snap.com beta crawler"
"Snapbot"
"SnapPreviewBot"
"sohu"
"SpankBot"
"Speedy Spider"
"Speedy_Spider"
"SpeedySpider"
"spider"
"SquigglebotBot"
"SurveyBot"
"SynapticSearch"
"T-H-U-N-D-E-R-S-T-O-N-E"
"Talkro Web-Shot"
"Tarantula"
"TerrawizBot"
"TheInformant"
"TMCrawler"
"TridentSpider"
"Tutorial Crawler"
"Twiceler"
"unwrapbot"
"URI::Fetch"
"VengaBot"
"Vonna.com b o t"
"Vortex"
"Votay bot"
"WebAlta Crawler"
"Webbot"
"Webclipping.com"
"WebCorp"
"Webinator"
"WIRE"
"WISEbot"
"Xerka WebBot"
"XSpider"
"YodaoBot"
"Yoono"
"yoono"
T{ rules
{ user-agents V{ "UbiCrawler" } }
{ allows V{ } }
{ disallows V{ URL" /" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "DOC" } }
{ allows V{ } }
{ disallows V{ URL" /" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "Zao" } }
{ allows V{ } }
{ disallows V{ URL" /" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "sitecheck.internetseer.com" } }
{ allows V{ } }
{ disallows V{ URL" /" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "Zealbot" } }
{ allows V{ } }
{ disallows V{ URL" /" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "MSIECrawler" } }
{ allows V{ } }
{ disallows V{ URL" /" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "SiteSnagger" } }
{ allows V{ } }
{ disallows V{ URL" /" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "WebStripper" } }
{ allows V{ } }
{ disallows V{ URL" /" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "WebCopier" } }
{ allows V{ } }
{ disallows V{ URL" /" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "Fetch" } }
{ allows V{ } }
{ disallows V{ URL" /" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "Offline Explorer" } }
{ allows V{ } }
{ disallows V{ URL" /" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "Teleport" } }
{ allows V{ } }
{ disallows V{ URL" /" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "TeleportPro" } }
{ allows V{ } }
{ disallows V{ URL" /" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "WebZIP" } }
{ allows V{ } }
{ disallows V{ URL" /" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "linko" } }
{ allows V{ } }
{ disallows V{ URL" /" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "HTTrack" } }
{ allows V{ } }
{ disallows V{ URL" /" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "Microsoft.URL.Control" } }
{ allows V{ } }
{ disallows V{ URL" /" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "Xenu" } }
{ allows V{ } }
{ disallows V{ URL" /" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "larbin" } }
{ allows V{ } }
{ disallows V{ URL" /" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "libwww" } }
{ allows V{ } }
{ disallows V{ URL" /" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "ZyBORG" } }
{ allows V{ } }
{ disallows V{ URL" /" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "Download Ninja" } }
{ allows V{ } }
{ disallows V{ URL" /" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "wget" } }
{ allows V{ } }
{ disallows V{ URL" /" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "grub-client" } }
{ allows V{ } }
{ disallows V{ URL" /" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "k2spider" } }
{ allows V{ } }
{ disallows V{ URL" /" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "NPBot" } }
{ allows V{ } }
{ disallows V{ URL" /" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents V{ "WebReaper" } }
{ allows V{ } }
{ disallows V{ URL" /" } }
{ unknowns H{ } }
}
T{ rules
{ user-agents
V{
"abot"
"ALeadSoftbot"
"BeijingCrawler"
"BilgiBot"
"bot"
"botlist"
"BOTW Spider"
"bumblebee"
"Bumblebee"
"BuzzRankingBot"
"Charlotte"
"Clushbot"
"Crawler"
"CydralSpider"
"DataFountains"
"DiamondBot"
"Dulance bot"
"DYNAMIC"
"EARTHCOM.info"
"EDI"
"envolk"
"Exabot"
"Exabot-Images"
"Exabot-Test"
"exactseek-pagereaper"
"Exalead NG"
"FANGCrawl"
"Feed::Find"
"flatlandbot"
"Gigabot"
"GigabotSiteSearch"
"GurujiBot"
"Hatena Antenna"
"Hatena Bookmark"
"Hatena RSS"
"HatenaScreenshot"
"Helix"
"HiddenMarket"
"HyperEstraier"
"iaskspider"
"IIITBOT"
"InfociousBot"
"iVia"
"iVia Page Fetcher"
"Jetbot"
"Kolinka Forum Search"
"KRetrieve"
"LetsCrawl.com"
"Lincoln State Web Browser"
"Links4US-Crawler"
"LOOQ"
"Lsearch/sondeur"
"MapoftheInternet.com"
"NationalDirectory"
"NetCarta_WebMapper"
"NewsGator"
"NextGenSearchBot"
"ng"
"nicebot"
"NP"
"NPBot"
"Nudelsalat"
"Nutch"
"OmniExplorer_Bot"
"OpenIntelligenceData"
"Oracle Enterprise Search"
"Pajaczek"
"panscient.com"
"PeerFactor 404 crawler"
"PeerFactor Crawler"
"PlantyNet"
"PlantyNet_WebRobot"
"plinki"
"PMAFind"
"Pogodak!"
"QuickFinder Crawler"
"Radiation Retriever"
"Reaper"
"RedCarpet"
"ScorpionBot"
"Scrubby"
"Scumbot"
"searchbot"
"Seeker.lookseek.com"
"SeznamBot"
"ShowXML"
"snap.com"
"snap.com beta crawler"
"Snapbot"
"SnapPreviewBot"
"sohu"
"SpankBot"
"Speedy Spider"
"Speedy_Spider"
"SpeedySpider"
"spider"
"SquigglebotBot"
"SurveyBot"
"SynapticSearch"
"T-H-U-N-D-E-R-S-T-O-N-E"
"Talkro Web-Shot"
"Tarantula"
"TerrawizBot"
"TheInformant"
"TMCrawler"
"TridentSpider"
"Tutorial Crawler"
"Twiceler"
"unwrapbot"
"URI::Fetch"
"VengaBot"
"Vonna.com b o t"
"Vortex"
"Votay bot"
"WebAlta Crawler"
"Webbot"
"Webclipping.com"
"WebCorp"
"Webinator"
"WIRE"
"WISEbot"
"Xerka WebBot"
"XSpider"
"YodaoBot"
"Yoono"
"yoono"
}
}
{ allows V{ } }
{ disallows V{ URL" /" } }
{ unknowns H{ } }
}
{ allows V{ } }
{ disallows V{ "/" } }
{ unknowns H{ } }
}
}
] [ "vocab:robots/robots.txt" utf8 file-contents parse-robots.txt ] unit-test

2
extra/robots/robots.factor
View File

@ -85,7 +85,7 @@ PRIVATE>
: parse-robots.txt ( string -- sitemaps rules-seq )
normalize-robots.txt [
[ <rules> dup ] dip [ parse-robots.txt-line drop ] with each
] map first ;
] map ;
: robots ( url -- robots )
>url