From 34c8e07900277a88659d600e036ebfbad8e210e2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 3 Apr 2009 10:35:43 -0500 Subject: [PATCH 01/20] make FSEEK macro for using _fseeki64 instead of fseeko on windows --- vm/io.c | 2 +- vm/os-genunix.h | 1 + vm/os-windows.h | 1 + 3 files changed, 3 insertions(+), 1 deletion(-) 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-genunix.h b/vm/os-genunix.h index 7afc68998d..9a00758c8a 100644 --- a/vm/os-genunix.h +++ b/vm/os-genunix.h @@ -1,5 +1,6 @@ #define DLLEXPORT #define NULL_DLL NULL +#define FSEEK fseeko void c_to_factor_toplevel(CELL quot); void init_signals(void); diff --git a/vm/os-windows.h b/vm/os-windows.h index 0704459dd0..f47ca951ee 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 _fseeki64 #ifdef WIN64 #define CELL_FORMAT "%Iu" From 4f3e8be3f6a3ad28e602fcd9ebf152abf80a2f05 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 3 Apr 2009 12:26:04 -0500 Subject: [PATCH 02/20] move FSEEK definition from os-genuinx.h to os-unix.h --- vm/os-genunix.h | 1 - vm/os-unix.h | 2 ++ 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/vm/os-genunix.h b/vm/os-genunix.h index 9a00758c8a..7afc68998d 100644 --- a/vm/os-genunix.h +++ b/vm/os-genunix.h @@ -1,6 +1,5 @@ #define DLLEXPORT #define NULL_DLL NULL -#define FSEEK fseeko void c_to_factor_toplevel(CELL quot); void init_signals(void); 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" From a42b872a23859635459e11522d11b20217df0997 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 3 Apr 2009 12:40:45 -0500 Subject: [PATCH 03/20] fix bug in take-sequence --- extra/html/parser/state/state-tests.factor | 3 +++ extra/html/parser/state/state.factor | 11 +++++++++-- 2 files changed, 12 insertions(+), 2 deletions(-) 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 ] [ From c780457ddb8c74e1d5289313da6fe9aaffb518cc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 3 Apr 2009 12:54:34 -0500 Subject: [PATCH 04/20] Fix up ui.offscreen --- extra/ui/offscreen/offscreen-docs.factor | 10 +++++----- extra/ui/offscreen/offscreen.factor | 18 ++++++++++++------ 2 files changed, 17 insertions(+), 11 deletions(-) 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 ; From 2ff6c7ed072bd090ea7b51a0d6af9cf80f90c80f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 3 Apr 2009 14:59:46 -0500 Subject: [PATCH 05/20] use fseek on windows instead of _fseeki64 --- vm/os-windows.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vm/os-windows.h b/vm/os-windows.h index f47ca951ee..36d350f50d 100755 --- a/vm/os-windows.h +++ b/vm/os-windows.h @@ -20,7 +20,7 @@ typedef wchar_t F_CHAR; #define STRNCMP wcsncmp #define STRDUP _wcsdup #define MIN(a,b) ((a)>(b)?(b):(a)) -#define FSEEK _fseeki64 +#define FSEEK fseek #ifdef WIN64 #define CELL_FORMAT "%Iu" From 775ca0a95647db832105fa163166e45d34076a7a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 3 Apr 2009 16:30:59 -0500 Subject: [PATCH 06/20] mason: run factor.com on windows --- extra/mason/child/child-tests.factor | 8 ++++++++ extra/mason/child/child.factor | 7 +++++-- 2 files changed, 13 insertions(+), 2 deletions(-) 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" [ From 32954b75ad46980d4a0f1e90c683bc2242de9fd3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 3 Apr 2009 17:28:31 -0500 Subject: [PATCH 07/20] use functors to define human-sort --- basis/sorting/human/human-docs.factor | 2 +- basis/sorting/human/human.factor | 17 ++--------------- 2 files changed, 3 insertions(+), 16 deletions(-) diff --git a/basis/sorting/human/human-docs.factor b/basis/sorting/human/human-docs.factor index 5952b3e3f9..606eef670a 100644 --- a/basis/sorting/human/human-docs.factor +++ b/basis/sorting/human/human-docs.factor @@ -35,7 +35,7 @@ HELP: human-compare HELP: human-sort { $values { "seq" sequence } - { "seq'" sequence } + { "sortedseq" sequence } } { $description "Sorts a sequence of objects by comparing the magnitude of any integers in the input string using the <=> word." } ; 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 >> From ce73c17c1d350a2743b1b3a96fea255aa9535c3b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 3 Apr 2009 17:28:55 -0500 Subject: [PATCH 08/20] add sorting.functor --- basis/sorting/functor/authors.txt | 1 + basis/sorting/functor/functor.factor | 24 ++++++++++++++++++++++++ 2 files changed, 25 insertions(+) create mode 100644 basis/sorting/functor/authors.txt create mode 100644 basis/sorting/functor/functor.factor 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..022ef3fb0d --- /dev/null +++ b/basis/sorting/functor/functor.factor @@ -0,0 +1,24 @@ +! 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}>=< +NAME-compare DEFINES ${NAME}-compare +NAME-sort DEFINES ${NAME}-sort +NAME-sort-keys DEFINES ${NAME}-sort-keys +NAME-sort-values DEFINES ${NAME}-sort-values + +WHERE + +: NAME<=> ( obj1 obj2 -- <=> ) QUOT bi@ <=> ; +: NAME>=< ( obj1 obj2 -- >=< ) NAME<=> invert-comparison ; +: NAME-compare ( obj1 obj2 quot -- <=> ) bi@ NAME<=> ; inline +: NAME-sort ( seq -- sortedseq ) [ NAME<=> ] sort ; +: NAME-sort-keys ( seq -- sortedseq ) [ [ first ] NAME-compare ] sort ; +: NAME-sort-values ( seq -- sortedseq ) [ [ second ] NAME-compare ] sort ; + +;FUNCTOR From 2e1652db6d5d9927e64e4d844b6a0efb04e73ad7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 3 Apr 2009 17:38:21 -0500 Subject: [PATCH 09/20] simplify sorting.slots a bit --- basis/sorting/slots/slots.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/sorting/slots/slots.factor b/basis/sorting/slots/slots.factor index 56b6a115f0..bce9442e44 100644 --- a/basis/sorting/slots/slots.factor +++ b/basis/sorting/slots/slots.factor @@ -20,7 +20,7 @@ PRIVATE> MACRO: compare-slots ( sort-specs -- <=> ) #! sort-spec: { accessors comparator } - [ slot-comparator ] map '[ _ 2|| +eq+ or ] ; + '[ _ [ slot-comparator ] map 2|| +eq+ or ] ; : sort-by-slots ( seq sort-specs -- seq' ) '[ _ compare-slots ] sort ; From 73a2fa49c53ad715bcfc625f164db36cf4fac742 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 3 Apr 2009 18:19:45 -0500 Subject: [PATCH 10/20] add title sort for use with joe's mp3 player --- basis/sorting/title/authors.txt | 1 + basis/sorting/title/title-tests.factor | 40 ++++++++++++++++++++++++++ basis/sorting/title/title.factor | 7 +++++ 3 files changed, 48 insertions(+) create mode 100644 basis/sorting/title/authors.txt create mode 100644 basis/sorting/title/title-tests.factor create mode 100644 basis/sorting/title/title.factor 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..34d9e90b38 --- /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 ; +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 +] 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 >> From 3137d12f12e3823a46a5350dad2c52639dbbdab3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 3 Apr 2009 19:30:07 -0500 Subject: [PATCH 11/20] Fix some minor UI bugs --- .../gadgets/line-support/line-support.factor | 3 +++ basis/ui/gadgets/scrollers/scrollers.factor | 1 + basis/ui/gadgets/tables/tables.factor | 25 ++++++++----------- 3 files changed, 15 insertions(+), 14 deletions(-) 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..b80940bd4a 100644 --- a/basis/ui/gadgets/scrollers/scrollers.factor +++ b/basis/ui/gadgets/scrollers/scrollers.factor @@ -58,6 +58,7 @@ M: viewport pref-dim* gadget-child pref-viewport-dim ; { [ 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..312cb59efd 100644 --- a/basis/ui/gadgets/tables/tables.factor +++ b/basis/ui/gadgets/tables/tables.factor @@ -261,19 +261,20 @@ M: table model-changed row-rect [ { 0 1 } v* ] change-dim ; : (select-row) ( table n -- ) - [ dup [ [ thin-row-rect ] [ drop ] 2bi scroll>rect ] [ 2drop ] if ] + [ dup [ [ thin-row-rect dup unparse show ] [ drop ] 2bi scroll>rect ] [ 2drop ] if ] [ >>selected-index relayout-1 ] 2bi ; : 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 From 695b97e6e6a593839b5f5f4f7b723de6ca815867 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 3 Apr 2009 19:35:22 -0500 Subject: [PATCH 12/20] Remove debug stuff --- basis/ui/gadgets/tables/tables.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/gadgets/tables/tables.factor b/basis/ui/gadgets/tables/tables.factor index 312cb59efd..77249149ae 100644 --- a/basis/ui/gadgets/tables/tables.factor +++ b/basis/ui/gadgets/tables/tables.factor @@ -261,7 +261,7 @@ M: table model-changed row-rect [ { 0 1 } v* ] change-dim ; : (select-row) ( table n -- ) - [ dup [ [ thin-row-rect dup unparse show ] [ drop ] 2bi scroll>rect ] [ 2drop ] if ] + [ dup [ [ thin-row-rect ] [ drop ] 2bi scroll>rect ] [ 2drop ] if ] [ >>selected-index relayout-1 ] 2bi ; From 8fdb3bb27aeb1969315585630d8d6c5c9caeba89 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 3 Apr 2009 19:43:10 -0500 Subject: [PATCH 13/20] define a sort-by to take a sequence of comparators without slots --- basis/sorting/slots/slots-tests.factor | 18 +++++++++++++++++- basis/sorting/slots/slots.factor | 14 ++++++++++++-- 2 files changed, 29 insertions(+), 3 deletions(-) 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 bce9442e44..4b6743af5c 100644 --- a/basis/sorting/slots/slots.factor +++ b/basis/sorting/slots/slots.factor @@ -7,6 +7,9 @@ IN: sorting.slots MACRO: compare-slots ( sort-specs -- <=> ) #! sort-spec: { accessors comparator } - '[ _ [ slot-comparator ] map 2|| +eq+ or ] ; + [ 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 ; + + MACRO: split-by-slots ( accessor-seqs -- quot ) [ [ '[ [ _ execute ] bi@ ] ] map concat [ = ] compose ] map '[ [ _ 2&& ] slice monotonic-slice ] ; From c97ca399d8ea5434b332c30ba1d25ab04d14c109 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 3 Apr 2009 19:49:49 -0500 Subject: [PATCH 14/20] refactor a bit, document sort-by --- basis/sorting/slots/slots-docs.factor | 15 ++++++++++++--- basis/sorting/slots/slots.factor | 7 +++---- 2 files changed, 15 insertions(+), 7 deletions(-) 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.factor b/basis/sorting/slots/slots.factor index 4b6743af5c..2dccc60821 100644 --- a/basis/sorting/slots/slots.factor +++ b/basis/sorting/slots/slots.factor @@ -8,7 +8,7 @@ IN: sorting.slots @@ -29,12 +29,11 @@ MACRO: compare-slots ( sort-specs -- <=> ) '[ _ compare-slots ] sort ; MACRO: compare-seq ( seq -- quot ) - [ short-circuit-comparator ] map '[ _ 2|| +eq+ or ] ; + [ '[ _ short-circuit-comparator ] ] map '[ _ 2|| +eq+ or ] ; : sort-by ( seq sort-seq -- sortedseq ) '[ _ compare-seq ] sort ; - MACRO: split-by-slots ( accessor-seqs -- quot ) [ [ '[ [ _ execute ] bi@ ] ] map concat [ = ] compose ] map '[ [ _ 2&& ] slice monotonic-slice ] ; From bae79235946230bab13e48dadd7890a6defcf633 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 3 Apr 2009 19:50:46 -0500 Subject: [PATCH 15/20] Fix more cosmetic issues --- basis/ui/gadgets/editors/editors.factor | 2 +- basis/ui/gadgets/scrollers/scrollers.factor | 1 - basis/ui/tools/listener/completion/completion.factor | 1 + 3 files changed, 2 insertions(+), 2 deletions(-) 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/scrollers/scrollers.factor b/basis/ui/gadgets/scrollers/scrollers.factor index b80940bd4a..a526cc618b 100644 --- a/basis/ui/gadgets/scrollers/scrollers.factor +++ b/basis/ui/gadgets/scrollers/scrollers.factor @@ -54,7 +54,6 @@ 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 ] 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 ; From 4c7b2f93379cf5925550747780f10d654d4577c2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 3 Apr 2009 20:05:19 -0500 Subject: [PATCH 16/20] fix deriving urls in spider --- extra/spider/spider.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/spider/spider.factor b/extra/spider/spider.factor index aeb4676767..5398e32ff4 100644 --- a/extra/spider/spider.factor +++ b/extra/spider/spider.factor @@ -84,7 +84,7 @@ TUPLE: unique-deque assoc deque ; : normalize-hrefs ( links spider -- links' ) currently-spidering>> present swap - [ dup url-absolute? [ derive-url ] [ url-append-path >url ] if ] with map ; + [ [ >url ] bi@ derive-url ] with map ; : print-spidering ( url depth -- ) "depth: " write number>string write From 8875c2ba26c8adeaf72e9bfeb6f58d40f59a3dde Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 3 Apr 2009 21:15:52 -0500 Subject: [PATCH 17/20] return links as URL objects in html vocab --- extra/html/parser/analyzer/analyzer.factor | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) 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 ; From 1ee52e2090aa1cf2aa223fbcf849b97bee4d0868 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 3 Apr 2009 21:16:08 -0500 Subject: [PATCH 18/20] refactoring spider --- extra/spider/spider.factor | 38 +++++++++++++++++++------------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/extra/spider/spider.factor b/extra/spider/spider.factor index 5398e32ff4..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 - [ [ >url ] bi@ derive-url ] 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 ; From 95f304bee0a8aa0654c1369bf0a06b15745dbcea Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 3 Apr 2009 21:16:27 -0500 Subject: [PATCH 19/20] Check in spider.report --- extra/spider/report/authors.txt | 1 + extra/spider/report/report.factor | 113 ++++++++++++++++++++++++++++++ 2 files changed, 114 insertions(+) create mode 100644 extra/spider/report/authors.txt create mode 100644 extra/spider/report/report.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 ; From 6f2c4fc02a137c92edc0ae7a677f9e0bcc11f3fb Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 4 Apr 2009 00:02:15 -0500 Subject: [PATCH 20/20] slim down the sorting.functor using more combinators --- basis/sorting/functor/functor.factor | 8 ------ basis/sorting/human/human-docs.factor | 35 -------------------------- basis/sorting/human/human-tests.factor | 4 +-- basis/sorting/slots/slots.factor | 10 ++++++-- basis/sorting/title/title-tests.factor | 4 +-- 5 files changed, 12 insertions(+), 49 deletions(-) diff --git a/basis/sorting/functor/functor.factor b/basis/sorting/functor/functor.factor index 022ef3fb0d..7f46af4c92 100644 --- a/basis/sorting/functor/functor.factor +++ b/basis/sorting/functor/functor.factor @@ -7,18 +7,10 @@ FUNCTOR: define-sorting ( NAME QUOT -- ) NAME<=> DEFINES ${NAME}<=> NAME>=< DEFINES ${NAME}>=< -NAME-compare DEFINES ${NAME}-compare -NAME-sort DEFINES ${NAME}-sort -NAME-sort-keys DEFINES ${NAME}-sort-keys -NAME-sort-values DEFINES ${NAME}-sort-values WHERE : NAME<=> ( obj1 obj2 -- <=> ) QUOT bi@ <=> ; : NAME>=< ( obj1 obj2 -- >=< ) NAME<=> invert-comparison ; -: NAME-compare ( obj1 obj2 quot -- <=> ) bi@ NAME<=> ; inline -: NAME-sort ( seq -- sortedseq ) [ NAME<=> ] sort ; -: NAME-sort-keys ( seq -- sortedseq ) [ [ first ] NAME-compare ] sort ; -: NAME-sort-values ( seq -- sortedseq ) [ [ second ] NAME-compare ] sort ; ;FUNCTOR diff --git a/basis/sorting/human/human-docs.factor b/basis/sorting/human/human-docs.factor index 606eef670a..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 } - { "sortedseq" 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/slots/slots.factor b/basis/sorting/slots/slots.factor index 2dccc60821..26458bb22c 100644 --- a/basis/sorting/slots/slots.factor +++ b/basis/sorting/slots/slots.factor @@ -7,8 +7,8 @@ IN: sorting.slots } sort-by ] unit-test