diff --git a/basis/sorting/functor/authors.txt b/basis/sorting/functor/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/sorting/functor/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/sorting/functor/functor.factor b/basis/sorting/functor/functor.factor new file mode 100644 index 0000000000..7f46af4c92 --- /dev/null +++ b/basis/sorting/functor/functor.factor @@ -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 diff --git a/basis/sorting/human/human-docs.factor b/basis/sorting/human/human-docs.factor index 5952b3e3f9..4bb62b1313 100644 --- a/basis/sorting/human/human-docs.factor +++ b/basis/sorting/human/human-docs.factor @@ -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 } ; diff --git a/basis/sorting/human/human-tests.factor b/basis/sorting/human/human-tests.factor index 0e20b54c2f..519e0064b6 100644 --- a/basis/sorting/human/human-tests.factor +++ b/basis/sorting/human/human-tests.factor @@ -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 diff --git a/basis/sorting/human/human.factor b/basis/sorting/human/human.factor index c07ed8758b..b3dae45a9b 100644 --- a/basis/sorting/human/human.factor +++ b/basis/sorting/human/human.factor @@ -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 >> diff --git a/basis/sorting/slots/slots-docs.factor b/basis/sorting/slots/slots-docs.factor index a3bdbf9ac1..cc89d497e7 100644 --- a/basis/sorting/slots/slots-docs.factor +++ b/basis/sorting/slots/slots-docs.factor @@ -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" diff --git a/basis/sorting/slots/slots-tests.factor b/basis/sorting/slots/slots-tests.factor index 46824c6fdb..83900461c3 100644 --- a/basis/sorting/slots/slots-tests.factor +++ b/basis/sorting/slots/slots-tests.factor @@ -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 diff --git a/basis/sorting/slots/slots.factor b/basis/sorting/slots/slots.factor index 56b6a115f0..26458bb22c 100644 --- a/basis/sorting/slots/slots.factor +++ b/basis/sorting/slots/slots.factor @@ -7,13 +7,16 @@ IN: sorting.slots @@ -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 ] ; diff --git a/basis/sorting/title/authors.txt b/basis/sorting/title/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/sorting/title/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/sorting/title/title-tests.factor b/basis/sorting/title/title-tests.factor new file mode 100644 index 0000000000..65a58e463d --- /dev/null +++ b/basis/sorting/title/title-tests.factor @@ -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 diff --git a/basis/sorting/title/title.factor b/basis/sorting/title/title.factor new file mode 100644 index 0000000000..dbdbf8a8fb --- /dev/null +++ b/basis/sorting/title/title.factor @@ -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 >> diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index f5b7f63d22..3eb40a5135 100755 --- a/basis/ui/gadgets/editors/editors.factor +++ b/basis/ui/gadgets/editors/editors.factor @@ -141,7 +141,7 @@ M: editor ungraft* : scroll>caret ( editor -- ) dup graft-state>> second [ [ - [ caret-loc ] [ caret-dim { 1 0 } v+ ] bi + [ caret-loc ] [ caret-dim { 2 1 } v+ ] bi ] keep scroll>rect ] [ drop ] if ; diff --git a/basis/ui/gadgets/line-support/line-support.factor b/basis/ui/gadgets/line-support/line-support.factor index 80feb31ad2..b9fe10c530 100644 --- a/basis/ui/gadgets/line-support/line-support.factor +++ b/basis/ui/gadgets/line-support/line-support.factor @@ -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 diff --git a/basis/ui/gadgets/scrollers/scrollers.factor b/basis/ui/gadgets/scrollers/scrollers.factor index 64e035c81b..a526cc618b 100644 --- a/basis/ui/gadgets/scrollers/scrollers.factor +++ b/basis/ui/gadgets/scrollers/scrollers.factor @@ -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 ] 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 ] diff --git a/basis/ui/gadgets/tables/tables.factor b/basis/ui/gadgets/tables/tables.factor index f2ed5b10e0..77249149ae 100644 --- a/basis/ui/gadgets/tables/tables.factor +++ b/basis/ui/gadgets/tables/tables.factor @@ -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 ; + > 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 diff --git a/basis/ui/tools/listener/completion/completion.factor b/basis/ui/tools/listener/completion/completion.factor index 022a2daabf..ba66121bc2 100644 --- a/basis/ui/tools/listener/completion/completion.factor +++ b/basis/ui/tools/listener/completion/completion.factor @@ -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 ; diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index 54b8c8fc69..2196f1baaa 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -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 ; diff --git a/extra/html/parser/state/state-tests.factor b/extra/html/parser/state/state-tests.factor index 75db1a373e..c8a8a95892 100644 --- a/extra/html/parser/state/state-tests.factor +++ b/extra/html/parser/state/state-tests.factor @@ -99,3 +99,6 @@ IN: html.parser.state.tests [ "" ] [ "abc" dup "abc" take-sequence drop take-rest ] unit-test + +[ f ] +[ "abc" "abcdefg" take-sequence ] unit-test diff --git a/extra/html/parser/state/state.factor b/extra/html/parser/state/state.factor index 5f845ce810..2bcd08be5f 100644 --- a/extra/html/parser/state/state.factor +++ b/extra/html/parser/state/state.factor @@ -51,9 +51,16 @@ TUPLE: state-parser sequence n ; : take-while ( state-parser quot: ( obj -- ? ) -- sequence/f ) [ not ] compose take-until ; inline +: ( 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 - sequence sequence= [ + state-parser [ n>> dup sequence length + ] [ sequence>> ] bi + sequence sequence= [ sequence state-parser [ sequence length + ] change-n drop ] [ diff --git a/extra/mason/child/child-tests.factor b/extra/mason/child/child-tests.factor index 104360e1fa..27bb42ed07 100644 --- a/extra/mason/child/child-tests.factor +++ b/extra/mason/child/child-tests.factor @@ -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 diff --git a/extra/mason/child/child.factor b/extra/mason/child/child.factor index 2ed9226524..feb11933fb 100755 --- a/extra/mason/child/child.factor +++ b/extra/mason/child/child.factor @@ -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" [ diff --git a/extra/spider/report/authors.txt b/extra/spider/report/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/spider/report/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/spider/report/report.factor b/extra/spider/report/report.factor new file mode 100644 index 0000000000..8bb4f91f82 --- /dev/null +++ b/extra/spider/report/report.factor @@ -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 + ><-><-> seconds + XML] + ] map [XML <->
XML] ; + +: report-broken-pages ( -- html ) + broken-pages get info-table ; + +: report-network-failures ( -- html ) + network-failures get [ + dup [XML
  • ><->
    • XML] + ] map [XML
      <->
    XML] ; + +: slowest-pages-table ( -- html ) + slowest-pages get info-table ; + +: timing-summary-table ( -- html ) + mean-time get + median-time get + time-std get + [XML + + + + +
    Mean<-> seconds
    Median<-> seconds
    Standard deviation<-> seconds
    + XML] ; + +: report-timings ( -- html ) + slowest-pages-table + timing-summary-table + [XML +

    Slowest pages

    + <-> + +

    Summary

    + <-> + XML] ; + +: generate-report ( -- html ) + report-broken-pages + report-network-failures + report-timings + [XML +

    Broken pages

    + <-> + +

    Network failures

    + <-> + +

    Load times

    + <-> + XML] ; + +: spider-report ( spider -- html ) + [ spidered>> process-results generate-report ] with-scope ; diff --git a/extra/spider/spider.factor b/extra/spider/spider.factor index aeb4676767..07989860ff 100644 --- a/extra/spider/spider.factor +++ b/extra/spider/spider.factor @@ -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 ; > 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 ; diff --git a/extra/ui/offscreen/offscreen-docs.factor b/extra/ui/offscreen/offscreen-docs.factor index 4123a83675..b9d68ffaeb 100644 --- a/extra/ui/offscreen/offscreen-docs.factor +++ b/extra/ui/offscreen/offscreen-docs.factor @@ -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: @@ -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 diff --git a/extra/ui/offscreen/offscreen.factor b/extra/ui/offscreen/offscreen.factor index f0b81ccacd..8d197eb844 100755 --- a/extra/ui/offscreen/offscreen.factor +++ b/extra/ui/offscreen/offscreen.factor @@ -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 - [ 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 ) + + { 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 ; diff --git a/vm/io.c b/vm/io.c index 950b1ed080..d88f1bab50 100755 --- a/vm/io.c +++ b/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(); diff --git a/vm/os-unix.h b/vm/os-unix.h index d2f34b4bc4..35abfee41c 100755 --- a/vm/os-unix.h +++ b/vm/os-unix.h @@ -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" diff --git a/vm/os-windows.h b/vm/os-windows.h index 0704459dd0..36d350f50d 100755 --- a/vm/os-windows.h +++ b/vm/os-windows.h @@ -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"