Merge branch 'master' of git://factorcode.org/git/factor
John Benediktsson
commit
1df6083785
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,16 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: functors kernel math.order sequences sorting ;
|
||||
IN: sorting.functor
|
||||
|
||||
FUNCTOR: define-sorting ( NAME QUOT -- )
|
||||
|
||||
NAME<=> DEFINES ${NAME}<=>
|
||||
NAME>=< DEFINES ${NAME}>=<
|
||||
|
||||
WHERE
|
||||
|
||||
: NAME<=> ( obj1 obj2 -- <=> ) QUOT bi@ <=> ;
|
||||
: NAME>=< ( obj1 obj2 -- >=< ) NAME<=> invert-comparison ;
|
||||
|
||||
;FUNCTOR
|
||||
|
|
@ -25,46 +25,11 @@ HELP: human>=<
|
|||
}
|
||||
{ $description "Compares two objects using the " { $link human<=> } " word and inverts the result." } ;
|
||||
|
||||
HELP: human-compare
|
||||
{ $values
|
||||
{ "obj1" object } { "obj2" object } { "quot" quotation }
|
||||
{ "<=>" "an ordering specifier" }
|
||||
}
|
||||
{ $description "Compares the results of applying the quotation to both objects via <=>." } ;
|
||||
|
||||
HELP: human-sort
|
||||
{ $values
|
||||
{ "seq" sequence }
|
||||
{ "seq'" sequence }
|
||||
}
|
||||
{ $description "Sorts a sequence of objects by comparing the magnitude of any integers in the input string using the <=> word." } ;
|
||||
|
||||
HELP: human-sort-keys
|
||||
{ $values
|
||||
{ "seq" "an alist" }
|
||||
{ "sortedseq" "a new sorted sequence" }
|
||||
}
|
||||
{ $description "Sorts the elements comparing first elements of pairs using the " { $link human<=> } " word." } ;
|
||||
|
||||
HELP: human-sort-values
|
||||
{ $values
|
||||
{ "seq" "an alist" }
|
||||
{ "sortedseq" "a new sorted sequence" }
|
||||
}
|
||||
{ $description "Sorts the elements comparing second elements of pairs using the " { $link human<=> } " word." } ;
|
||||
|
||||
{ <=> >=< human-compare human-sort human-sort-keys human-sort-values } related-words
|
||||
|
||||
ARTICLE: "sorting.human" "Human-friendly sorting"
|
||||
"The " { $vocab-link "sorting.human" } " vocabulary sorts by numbers as a human would -- by comparing their magnitudes -- rather than in a lexicographic way. For example, sorting a1, a10, a03, a2 with human sort returns a1, a2, a03, a10, while sorting with natural sort returns a03, a1, a10, a2." $nl
|
||||
"Comparing two objects:"
|
||||
{ $subsection human<=> }
|
||||
{ $subsection human>=< }
|
||||
{ $subsection human-compare }
|
||||
"Sort a sequence:"
|
||||
{ $subsection human-sort }
|
||||
{ $subsection human-sort-keys }
|
||||
{ $subsection human-sort-values }
|
||||
"Splitting a string into substrings and integers:"
|
||||
{ $subsection find-numbers } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: sorting.human tools.test ;
|
||||
USING: sorting.human tools.test sorting.slots ;
|
||||
IN: sorting.human.tests
|
||||
|
||||
\ human-sort must-infer
|
||||
|
||||
[ { "x1y" "x2" "x10y" } ] [ { "x1y" "x10y" "x2" } human-sort ] unit-test
|
||||
[ { "x1y" "x2" "x10y" } ] [ { "x1y" "x10y" "x2" } { human<=> } sort-by ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,22 +1,9 @@
|
|||
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: peg.ebnf math.parser kernel assocs sorting fry
|
||||
math.order sequences ascii splitting.monotonic ;
|
||||
USING: math.parser peg.ebnf sorting.functor ;
|
||||
IN: sorting.human
|
||||
|
||||
: find-numbers ( string -- seq )
|
||||
[EBNF Result = ([0-9]+ => [[ string>number ]] | (!([0-9]) .)+)* EBNF] ;
|
||||
|
||||
: human<=> ( obj1 obj2 -- <=> ) [ find-numbers ] bi@ <=> ;
|
||||
|
||||
: human>=< ( obj1 obj2 -- >=< ) human<=> invert-comparison ; inline
|
||||
|
||||
: human-compare ( obj1 obj2 quot -- <=> ) bi@ human<=> ; inline
|
||||
|
||||
: human-sort ( seq -- seq' ) [ human<=> ] sort ;
|
||||
|
||||
: human-sort-keys ( seq -- sortedseq )
|
||||
[ [ first ] human-compare ] sort ;
|
||||
|
||||
: human-sort-values ( seq -- sortedseq )
|
||||
[ [ second ] human-compare ] sort ;
|
||||
<< "human" [ find-numbers ] define-sorting >>
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ HELP: compare-slots
|
|||
HELP: sort-by-slots
|
||||
{ $values
|
||||
{ "seq" sequence } { "sort-specs" "a sequence of accessors ending with a comparator" }
|
||||
{ "seq'" sequence }
|
||||
{ "sortedseq" sequence }
|
||||
}
|
||||
{ $description "Sorts a sequence of tuples by the sort-specs in " { $snippet "sort-spec" } ". A sort-spec is a sequence of slot accessors ending in a comparator." }
|
||||
{ $examples
|
||||
|
|
@ -39,11 +39,20 @@ HELP: split-by-slots
|
|||
}
|
||||
{ $description "Splits a sequence of tuples into a sequence of slices of tuples that have the same values in all slots in the accessor sequence. This word is only useful for splitting a sorted sequence, but is more efficient than partitioning in such a case." } ;
|
||||
|
||||
HELP: sort-by
|
||||
{ $values
|
||||
{ "seq" sequence } { "sort-seq" "a sequence of comparators" }
|
||||
{ "sortedseq" sequence }
|
||||
}
|
||||
{ $description "Sorts a sequence by comparing elements by comparators, using subsequent comparators when there is a tie." } ;
|
||||
|
||||
ARTICLE: "sorting.slots" "Sorting by slots"
|
||||
"The " { $vocab-link "sorting.slots" } " vocabulary can sort tuples by slot in ascending or descending order, using subsequent slots as tie-breakers." $nl
|
||||
"Comparing two objects by a sequence of slots:"
|
||||
{ $subsection compare-slots }
|
||||
"Sorting a sequence by a sequence of slots:"
|
||||
{ $subsection sort-by-slots } ;
|
||||
"Sorting a sequence of tuples by a slot/comparator pairs:"
|
||||
{ $subsection sort-by-slots }
|
||||
"Sorting a sequence by a sequence of comparators:"
|
||||
{ $subsection sort-by } ;
|
||||
|
||||
ABOUT: "sorting.slots"
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors math.order sorting.slots tools.test
|
||||
sorting.human arrays sequences kernel assocs multiline ;
|
||||
sorting.human arrays sequences kernel assocs multiline
|
||||
sorting.functor ;
|
||||
IN: sorting.literals.tests
|
||||
|
||||
TUPLE: sort-test a b c tuple2 ;
|
||||
|
|
@ -76,6 +77,9 @@ TUPLE: tuple2 d ;
|
|||
[ { } ]
|
||||
[ { } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots ] unit-test
|
||||
|
||||
[ { } ]
|
||||
[ { } { } sort-by-slots ] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 1 } } } }
|
||||
|
|
@ -143,3 +147,15 @@ TUPLE: tuple2 d ;
|
|||
T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 4 } } } }
|
||||
} { { tuple2>> d>> } { a>> } } split-by-slots [ >array ] map
|
||||
] unit-test
|
||||
|
||||
|
||||
[ { "a" "b" "c" } ] [ { "b" "c" "a" } { <=> <=> } sort-by ] unit-test
|
||||
[ { "b" "c" "a" } ] [ { "b" "c" "a" } { } sort-by ] unit-test
|
||||
|
||||
<< "length-test" [ length ] define-sorting >>
|
||||
|
||||
[ { { 1 } { 1 2 3 } { 1 3 2 } { 3 2 1 } } ]
|
||||
[
|
||||
{ { 3 2 1 } { 1 2 3 } { 1 3 2 } { 1 } }
|
||||
{ length-test<=> <=> } sort-by
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -7,13 +7,16 @@ IN: sorting.slots
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: short-circuit-comparator ( obj1 obj2 word -- comparator/? )
|
||||
execute dup +eq+ eq? [ drop f ] when ;
|
||||
|
||||
: slot-comparator ( seq -- quot )
|
||||
[
|
||||
but-last-slice
|
||||
[ '[ [ _ execute ] bi@ ] ] map concat
|
||||
] [
|
||||
peek
|
||||
'[ @ _ execute dup +eq+ eq? [ drop f ] when ]
|
||||
'[ @ _ short-circuit-comparator ]
|
||||
] bi ;
|
||||
|
||||
PRIVATE>
|
||||
|
|
@ -22,9 +25,21 @@ MACRO: compare-slots ( sort-specs -- <=> )
|
|||
#! sort-spec: { accessors comparator }
|
||||
[ slot-comparator ] map '[ _ 2|| +eq+ or ] ;
|
||||
|
||||
: sort-by-slots ( seq sort-specs -- seq' )
|
||||
: sort-by-slots ( seq sort-specs -- sortedseq )
|
||||
'[ _ compare-slots ] sort ;
|
||||
|
||||
MACRO: compare-seq ( seq -- quot )
|
||||
[ '[ _ short-circuit-comparator ] ] map '[ _ 2|| +eq+ or ] ;
|
||||
|
||||
: sort-by ( seq sort-seq -- sortedseq )
|
||||
'[ _ compare-seq ] sort ;
|
||||
|
||||
: sort-keys-by ( seq sort-seq -- sortedseq )
|
||||
'[ [ first ] bi@ _ compare-seq ] sort ;
|
||||
|
||||
: sort-values-by ( seq sort-seq -- sortedseq )
|
||||
'[ [ second ] bi@ _ compare-seq ] sort ;
|
||||
|
||||
MACRO: split-by-slots ( accessor-seqs -- quot )
|
||||
[ [ '[ [ _ execute ] bi@ ] ] map concat [ = ] compose ] map
|
||||
'[ [ _ 2&& ] slice monotonic-slice ] ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,40 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test sorting.title sorting.slots ;
|
||||
IN: sorting.title.tests
|
||||
|
||||
: sort-me ( -- seq )
|
||||
{
|
||||
"The Beatles"
|
||||
"A river runs through it"
|
||||
"Another"
|
||||
"la vida loca"
|
||||
"Basketball"
|
||||
"racquetball"
|
||||
"Los Fujis"
|
||||
"los Fujis"
|
||||
"La cucaracha"
|
||||
"a day to remember"
|
||||
"of mice and men"
|
||||
"on belay"
|
||||
"for the horde"
|
||||
} ;
|
||||
[
|
||||
{
|
||||
"Another"
|
||||
"Basketball"
|
||||
"The Beatles"
|
||||
"La cucaracha"
|
||||
"a day to remember"
|
||||
"for the horde"
|
||||
"Los Fujis"
|
||||
"los Fujis"
|
||||
"of mice and men"
|
||||
"on belay"
|
||||
"racquetball"
|
||||
"A river runs through it"
|
||||
"la vida loca"
|
||||
}
|
||||
] [
|
||||
sort-me { title<=> } sort-by
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: sorting.functor regexp kernel accessors sequences
|
||||
unicode.case ;
|
||||
IN: sorting.title
|
||||
|
||||
<< "title" [ >lower dup R/ ^(the|a|an|el|la|los|las|il) / first-match [ to>> tail-slice ] when* ] define-sorting >>
|
||||
|
|
@ -141,7 +141,7 @@ M: editor ungraft*
|
|||
: scroll>caret ( editor -- )
|
||||
dup graft-state>> second [
|
||||
[
|
||||
[ caret-loc ] [ caret-dim { 1 0 } v+ ] bi <rect>
|
||||
[ caret-loc ] [ caret-dim { 2 1 } v+ ] bi <rect>
|
||||
] keep scroll>rect
|
||||
] [ drop ] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -30,6 +30,9 @@ M: line-gadget line-height font>> font-metrics height>> ceiling ;
|
|||
: validate-line ( m gadget -- n )
|
||||
control-value [ drop f ] [ length 1- min 0 max ] if-empty ;
|
||||
|
||||
: valid-line? ( n gadget -- ? )
|
||||
control-value length 1- 0 swap between? ;
|
||||
|
||||
: visible-line ( gadget quot -- n )
|
||||
'[
|
||||
[ clip get @ origin get [ second ] bi@ - ] dip
|
||||
|
|
|
|||
|
|
@ -54,10 +54,10 @@ M: viewport pref-dim* gadget-child pref-viewport-dim ;
|
|||
2dup control-value = [ 2drop ] [ set-control-value ] if ;
|
||||
|
||||
: (scroll>rect) ( rect scroller -- )
|
||||
[ [ loc>> ] [ dim>> { 1 1 } v+ ] bi <rect> ] dip
|
||||
{
|
||||
[ scroller-value vneg offset-rect ]
|
||||
[ viewport>> dim>> rect-min ]
|
||||
[ viewport>> loc>> offset-rect ]
|
||||
[ viewport>> [ v- { 0 0 } vmin ] [ v- { 0 0 } vmax ] with-rect-extents v+ ]
|
||||
[ scroller-value v+ ]
|
||||
[ scroll ]
|
||||
|
|
|
|||
|
|
@ -268,12 +268,13 @@ M: table model-changed
|
|||
: mouse-row ( table -- n )
|
||||
[ hand-rel second ] keep y>line ;
|
||||
|
||||
: if-mouse-row ( table true: ( table mouse-index -- ) false: ( table -- ) -- )
|
||||
[ [ mouse-row ] keep 2dup valid-line? ]
|
||||
[ ] [ '[ nip @ ] ] tri* if ; inline
|
||||
|
||||
: table-button-down ( table -- )
|
||||
dup takes-focus?>> [ dup request-focus ] when
|
||||
dup control-value empty? [ drop ] [
|
||||
dup [ mouse-row ] keep validate-line
|
||||
[ >>mouse-index ] [ (select-row) ] bi
|
||||
] if ;
|
||||
[ swap [ >>mouse-index ] [ (select-row) ] bi ] [ drop ] if-mouse-row ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
@ -283,11 +284,14 @@ PRIVATE>
|
|||
[ 2drop ]
|
||||
if ;
|
||||
|
||||
: row-action? ( table -- ? )
|
||||
[ [ mouse-row ] keep valid-line? ]
|
||||
[ single-click?>> hand-click# get 2 = or ] bi and ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: table-button-up ( table -- )
|
||||
dup single-click?>> hand-click# get 2 = or
|
||||
[ row-action ] [ update-selected-value ] if ;
|
||||
dup row-action? [ row-action ] [ update-selected-value ] if ;
|
||||
|
||||
: select-row ( table n -- )
|
||||
over validate-line
|
||||
|
|
@ -320,13 +324,6 @@ PRIVATE>
|
|||
: next-page ( table -- )
|
||||
1 prev/next-page ;
|
||||
|
||||
: valid-row? ( row table -- ? )
|
||||
control-value length 1- 0 swap between? ;
|
||||
|
||||
: if-mouse-row ( table true false -- )
|
||||
[ [ mouse-row ] keep 2dup valid-row? ]
|
||||
[ ] [ '[ nip @ ] ] tri* if ; inline
|
||||
|
||||
: show-mouse-help ( table -- )
|
||||
[
|
||||
swap
|
||||
|
|
|
|||
|
|
@ -141,6 +141,7 @@ GENERIC# accept-completion-hook 1 ( item popup -- )
|
|||
t >>selection-required?
|
||||
t >>single-click?
|
||||
30 >>min-cols
|
||||
10 >>min-rows
|
||||
10 >>max-rows
|
||||
dup '[ _ accept-completion ] >>action ;
|
||||
|
||||
|
|
|
|||
|
|
@ -127,11 +127,13 @@ TUPLE: link attributes clickable ;
|
|||
[ name>> "a" = ]
|
||||
[ attributes>> "href" swap key? ] bi and ] filter
|
||||
] map sift
|
||||
[ [ attributes>> "href" swap at ] map ] map concat ;
|
||||
[ [ attributes>> "href" swap at ] map ] map concat
|
||||
[ >url ] map ;
|
||||
|
||||
: find-frame-links ( vector -- vector' )
|
||||
[ name>> "frame" = ] find-between-all
|
||||
[ [ attributes>> "src" swap at ] map sift ] map concat sift ;
|
||||
[ [ attributes>> "src" swap at ] map sift ] map concat sift
|
||||
[ >url ] map ;
|
||||
|
||||
: find-all-links ( vector -- vector' )
|
||||
[ find-hrefs ] [ find-frame-links ] bi append prune ;
|
||||
|
|
|
|||
|
|
@ -99,3 +99,6 @@ IN: html.parser.state.tests
|
|||
|
||||
[ "" ]
|
||||
[ "abc" <state-parser> dup "abc" take-sequence drop take-rest ] unit-test
|
||||
|
||||
[ f ]
|
||||
[ "abc" <state-parser> "abcdefg" take-sequence ] unit-test
|
||||
|
|
|
|||
|
|
@ -51,9 +51,16 @@ TUPLE: state-parser sequence n ;
|
|||
: take-while ( state-parser quot: ( obj -- ? ) -- sequence/f )
|
||||
[ not ] compose take-until ; inline
|
||||
|
||||
: <safe-slice> ( from to seq -- slice/f )
|
||||
3dup {
|
||||
[ 2drop 0 < ]
|
||||
[ [ drop ] 2dip length > ]
|
||||
[ drop > ]
|
||||
} 3|| [ 3drop f ] [ slice boa ] if ; inline
|
||||
|
||||
:: take-sequence ( state-parser sequence -- obj/f )
|
||||
state-parser [ n>> dup sequence length + ] [ sequence>> ] bi <slice>
|
||||
sequence sequence= [
|
||||
state-parser [ n>> dup sequence length + ] [ sequence>> ] bi
|
||||
<safe-slice> sequence sequence= [
|
||||
sequence
|
||||
state-parser [ sequence length + ] change-n drop
|
||||
] [
|
||||
|
|
|
|||
|
|
@ -32,3 +32,11 @@ USING: mason.child mason.config tools.test namespaces ;
|
|||
boot-cmd
|
||||
] with-scope
|
||||
] unit-test
|
||||
|
||||
[ { "./factor.com" "-i=boot.x86.32.image" "-no-user-init" } ] [
|
||||
[
|
||||
"winnt" target-os set
|
||||
"x86.32" target-cpu set
|
||||
boot-cmd
|
||||
] with-scope
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -25,8 +25,11 @@ IN: mason.child
|
|||
builds-factor-image "." copy-file-into
|
||||
builds-factor-image "factor" copy-file-into ;
|
||||
|
||||
: factor-vm ( -- string )
|
||||
target-os get "winnt" = "./factor.com" "./factor" ? ;
|
||||
|
||||
: boot-cmd ( -- cmd )
|
||||
"./factor"
|
||||
factor-vm
|
||||
"-i=" boot-image-name append
|
||||
"-no-user-init"
|
||||
3array ;
|
||||
|
|
@ -42,7 +45,7 @@ IN: mason.child
|
|||
try-process
|
||||
] with-directory ;
|
||||
|
||||
: test-cmd ( -- cmd ) { "./factor" "-run=mason.test" } ;
|
||||
: test-cmd ( -- cmd ) factor-vm "-run=mason.test" 2array ;
|
||||
|
||||
: test ( -- )
|
||||
"factor" [
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,113 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs combinators kernel math
|
||||
math.statistics namespaces sequences sorting xml.syntax
|
||||
spider ;
|
||||
IN: spider.report
|
||||
|
||||
SYMBOL: network-failures
|
||||
SYMBOL: broken-pages
|
||||
SYMBOL: timings
|
||||
|
||||
: record-broken-page ( url spider-result -- )
|
||||
headers>> [ code>> ] [ message>> ] bi 2array 2array
|
||||
broken-pages push ;
|
||||
|
||||
: record-page-timings ( url spider-result -- )
|
||||
fetch-time>> 2array timings get push ;
|
||||
|
||||
: record-network-failure ( url -- )
|
||||
network-failures get push ;
|
||||
|
||||
: process-result ( url spider-result -- )
|
||||
{
|
||||
{ f [ record-network-failure ] }
|
||||
[
|
||||
dup headers>> code>> 200 =
|
||||
[ record-page-timings ] [ record-broken-page ] if
|
||||
]
|
||||
} case ;
|
||||
|
||||
CONSTANT: slowest 5
|
||||
|
||||
SYMBOL: slowest-pages
|
||||
SYMBOL: mean-time
|
||||
SYMBOL: median-time
|
||||
SYMBOL: time-std
|
||||
|
||||
: process-timings ( -- )
|
||||
timings get sort-values
|
||||
[ slowest short tail* reverse slowest-pages set ]
|
||||
[
|
||||
values
|
||||
[ mean 1000000 /f mean-time set ]
|
||||
[ median 1000000 /f median-time set ]
|
||||
[ std 1000000 /f time-std set ] tri
|
||||
] bi ;
|
||||
|
||||
: process-results ( results -- )
|
||||
V{ } clone network-failures set
|
||||
V{ } clone broken-pages set
|
||||
V{ } clone timings set
|
||||
[ process-result ] assoc-each
|
||||
process-timings ;
|
||||
|
||||
: info-table ( alist -- html )
|
||||
[
|
||||
first2 dupd 1000000 /f
|
||||
[XML
|
||||
<tr><td><a href=<->><-></a></td><td><-> seconds</td></tr>
|
||||
XML]
|
||||
] map [XML <table border="1"><-></table> XML] ;
|
||||
|
||||
: report-broken-pages ( -- html )
|
||||
broken-pages get info-table ;
|
||||
|
||||
: report-network-failures ( -- html )
|
||||
network-failures get [
|
||||
dup [XML <li><a href=<->><-></a></li> XML]
|
||||
] map [XML <ul><-></ul> XML] ;
|
||||
|
||||
: slowest-pages-table ( -- html )
|
||||
slowest-pages get info-table ;
|
||||
|
||||
: timing-summary-table ( -- html )
|
||||
mean-time get
|
||||
median-time get
|
||||
time-std get
|
||||
[XML
|
||||
<table border="1">
|
||||
<tr><th>Mean</th><td><-> seconds</td></tr>
|
||||
<tr><th>Median</th><td><-> seconds</td></tr>
|
||||
<tr><th>Standard deviation</th><td><-> seconds</td></tr>
|
||||
</table>
|
||||
XML] ;
|
||||
|
||||
: report-timings ( -- html )
|
||||
slowest-pages-table
|
||||
timing-summary-table
|
||||
[XML
|
||||
<h2>Slowest pages</h2>
|
||||
<->
|
||||
|
||||
<h2>Summary</h2>
|
||||
<->
|
||||
XML] ;
|
||||
|
||||
: generate-report ( -- html )
|
||||
report-broken-pages
|
||||
report-network-failures
|
||||
report-timings
|
||||
[XML
|
||||
<h1>Broken pages</h1>
|
||||
<->
|
||||
|
||||
<h1>Network failures</h1>
|
||||
<->
|
||||
|
||||
<h1>Load times</h1>
|
||||
<->
|
||||
XML] ;
|
||||
|
||||
: spider-report ( spider -- html )
|
||||
[ spidered>> process-results generate-report ] with-scope ;
|
||||
|
|
@ -4,15 +4,15 @@ USING: accessors fry html.parser html.parser.analyzer
|
|||
http.client kernel tools.time sets assocs sequences
|
||||
concurrency.combinators io threads namespaces math multiline
|
||||
math.parser inspector urls logging combinators.short-circuit
|
||||
continuations calendar prettyprint dlists deques locals
|
||||
present ;
|
||||
continuations calendar prettyprint dlists deques locals ;
|
||||
IN: spider
|
||||
|
||||
TUPLE: spider base count max-count sleep max-depth initial-links
|
||||
filters spidered todo nonmatching quiet currently-spidering ;
|
||||
filters spidered todo nonmatching quiet currently-spidering
|
||||
#threads follow-robots ;
|
||||
|
||||
TUPLE: spider-result url depth headers fetch-time parsed-html
|
||||
links processing-time timestamp ;
|
||||
TUPLE: spider-result url depth headers
|
||||
fetched-in parsed-html links processed-in fetched-at ;
|
||||
|
||||
TUPLE: todo-url url depth ;
|
||||
|
||||
|
|
@ -51,7 +51,8 @@ TUPLE: unique-deque assoc deque ;
|
|||
0 >>max-depth
|
||||
0 >>count
|
||||
1/0. >>max-count
|
||||
H{ } clone >>spidered ;
|
||||
H{ } clone >>spidered
|
||||
1 >>#threads ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
|
@ -79,12 +80,8 @@ TUPLE: unique-deque assoc deque ;
|
|||
[ add-nonmatching ]
|
||||
[ tuck [ apply-filters ] 2dip add-todo ] 2bi ;
|
||||
|
||||
: url-absolute? ( url -- ? )
|
||||
present "http://" head? ;
|
||||
|
||||
: normalize-hrefs ( links spider -- links' )
|
||||
currently-spidering>> present swap
|
||||
[ dup url-absolute? [ derive-url ] [ url-append-path >url ] if ] with map ;
|
||||
: normalize-hrefs ( base links -- links' )
|
||||
[ derive-url ] with map ;
|
||||
|
||||
: print-spidering ( url depth -- )
|
||||
"depth: " write number>string write
|
||||
|
|
@ -94,7 +91,9 @@ TUPLE: unique-deque assoc deque ;
|
|||
f url spider spidered>> set-at
|
||||
[ url http-get ] benchmark :> fetch-time :> html :> headers
|
||||
[
|
||||
html parse-html [ ] [ find-all-links spider normalize-hrefs ] bi
|
||||
html parse-html
|
||||
spider currently-spidering>>
|
||||
over find-all-links normalize-hrefs
|
||||
] benchmark :> processing-time :> links :> parsed-html
|
||||
url depth headers fetch-time parsed-html links processing-time
|
||||
now spider-result boa ;
|
||||
|
|
@ -107,11 +106,12 @@ TUPLE: unique-deque assoc deque ;
|
|||
|
||||
\ spider-page ERROR add-error-logging
|
||||
|
||||
: spider-sleep ( spider -- )
|
||||
sleep>> [ sleep ] when* ;
|
||||
: spider-sleep ( spider -- ) sleep>> [ sleep ] when* ;
|
||||
|
||||
:: queue-initial-links ( spider -- spider )
|
||||
spider initial-links>> spider normalize-hrefs 0 spider add-todo spider ;
|
||||
: queue-initial-links ( spider -- )
|
||||
[
|
||||
[ currently-spidering>> ] [ initial-links>> ] bi normalize-hrefs 0
|
||||
] keep add-todo ;
|
||||
|
||||
: spider-page? ( spider -- ? )
|
||||
{
|
||||
|
|
@ -121,7 +121,7 @@ TUPLE: unique-deque assoc deque ;
|
|||
} 1&& ;
|
||||
|
||||
: setup-next-url ( spider -- spider url depth )
|
||||
dup todo>> peek-url url>> present >>currently-spidering
|
||||
dup todo>> peek-url url>> >>currently-spidering
|
||||
dup todo>> pop-url [ url>> ] [ depth>> ] bi ;
|
||||
|
||||
: spider-next-page ( spider -- )
|
||||
|
|
@ -138,5 +138,5 @@ PRIVATE>
|
|||
|
||||
: run-spider ( spider -- spider )
|
||||
"spider" [
|
||||
queue-initial-links [ run-spider-loop ] keep
|
||||
dup queue-initial-links [ run-spider-loop ] keep
|
||||
] with-logging ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Joe Groff.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax kernel quotations ui.gadgets
|
||||
images.bitmap strings ui.gadgets.worlds ;
|
||||
images strings ui.gadgets.worlds ;
|
||||
IN: ui.offscreen
|
||||
|
||||
HELP: <offscreen-world>
|
||||
|
|
@ -26,9 +26,9 @@ HELP: do-offscreen
|
|||
HELP: gadget>bitmap
|
||||
{ $values
|
||||
{ "gadget" gadget }
|
||||
{ "bitmap" bitmap }
|
||||
{ "image" image }
|
||||
}
|
||||
{ $description "Renders " { $snippet "gadget" } " to an " { $link offscreen-world } " and creates a " { $link bitmap } " from its contents." } ;
|
||||
{ $description "Renders " { $snippet "gadget" } " to an " { $link offscreen-world } " and creates an " { $link image } " from its contents." } ;
|
||||
|
||||
HELP: offscreen-world
|
||||
{ $class-description "The class of " { $link world } " objects that render to an offscreen buffer." } ;
|
||||
|
|
@ -36,9 +36,9 @@ HELP: offscreen-world
|
|||
HELP: offscreen-world>bitmap
|
||||
{ $values
|
||||
{ "world" offscreen-world }
|
||||
{ "bitmap" bitmap }
|
||||
{ "image" image }
|
||||
}
|
||||
{ $description "Saves a copy of the contents of " { $snippet "world" } " to a " { $link bitmap } " object." } ;
|
||||
{ $description "Saves a copy of the contents of " { $snippet "world" } " to a " { $link image } " object." } ;
|
||||
|
||||
HELP: open-offscreen
|
||||
{ $values
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! (c) 2008 Joe Groff, see license for details
|
||||
USING: accessors continuations images.bitmap kernel math
|
||||
USING: accessors alien.c-types continuations images kernel math
|
||||
sequences ui.gadgets ui.gadgets.private ui.gadgets.worlds
|
||||
ui.private ui ui.backend destructors ;
|
||||
ui.private ui ui.backend destructors locals ;
|
||||
IN: ui.offscreen
|
||||
|
||||
TUPLE: offscreen-world < world ;
|
||||
|
|
@ -19,18 +19,24 @@ M: offscreen-world ungraft*
|
|||
|
||||
: open-offscreen ( gadget -- world )
|
||||
"" f <offscreen-world>
|
||||
[ open-world-window dup relayout-1 ] keep
|
||||
[ open-world-window ] [ relayout-1 ] [ ] tri
|
||||
notify-queued ;
|
||||
|
||||
: close-offscreen ( world -- )
|
||||
ungraft notify-queued ;
|
||||
|
||||
: offscreen-world>bitmap ( world -- bitmap )
|
||||
offscreen-pixels bgra>bitmap ;
|
||||
:: bgrx>bitmap ( alien w h -- image )
|
||||
<image>
|
||||
{ w h } >>dim
|
||||
alien w h * 4 * memory>byte-array >>bitmap
|
||||
BGRX >>component-order ;
|
||||
|
||||
: offscreen-world>bitmap ( world -- image )
|
||||
offscreen-pixels bgrx>bitmap ;
|
||||
|
||||
: do-offscreen ( gadget quot: ( offscreen-world -- ) -- )
|
||||
[ open-offscreen ] dip
|
||||
over [ slip ] [ close-offscreen ] [ ] cleanup ; inline
|
||||
|
||||
: gadget>bitmap ( gadget -- bitmap )
|
||||
: gadget>bitmap ( gadget -- image )
|
||||
[ offscreen-world>bitmap ] do-offscreen ;
|
||||
|
|
|
|||
2
vm/io.c
2
vm/io.c
|
|
@ -179,7 +179,7 @@ void primitive_fseek(void)
|
|||
break;
|
||||
}
|
||||
|
||||
if(fseeko(file,offset,whence) == -1)
|
||||
if(FSEEK(file,offset,whence) == -1)
|
||||
{
|
||||
io_error();
|
||||
|
||||
|
|
|
|||
|
|
@ -23,6 +23,8 @@ typedef char F_SYMBOL;
|
|||
#define STRNCMP strncmp
|
||||
#define STRDUP strdup
|
||||
|
||||
#define FSEEK fseeko
|
||||
|
||||
#define FIXNUM_FORMAT "%ld"
|
||||
#define CELL_FORMAT "%lu"
|
||||
#define CELL_HEX_FORMAT "%lx"
|
||||
|
|
|
|||
|
|
@ -20,6 +20,7 @@ typedef wchar_t F_CHAR;
|
|||
#define STRNCMP wcsncmp
|
||||
#define STRDUP _wcsdup
|
||||
#define MIN(a,b) ((a)>(b)?(b):(a))
|
||||
#define FSEEK fseek
|
||||
|
||||
#ifdef WIN64
|
||||
#define CELL_FORMAT "%Iu"
|
||||
|
|
|
|||
Loading…
Reference in New Issue