Merge branch 'master' into smarter_error_list

Makefile

@@ -166,7 +166,7 @@ factor-ffi-test: vm/ffi_test.o
 
 clean:
 	rm -f vm/*.o
-	rm -f factor*.dll libfactor.{a,so,dylib} libfactor-ffi-test.{a,so,dylib}
+	rm -f factor*.dll libfactor.{a,so,dylib} libfactor-ffi-test.{a,so,dylib} Factor.app/Contents/Frameworks/libfactor.dylib
 
 vm/resources.o:
 	$(WINDRES) vm/factor.rs vm/resources.o

basis/alien/fortran/fortran.factor

@@ -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 ;

basis/colors/colors-docs.factor

@@ -23,7 +23,7 @@ $nl
 ARTICLE: "colors" "Colors"
 "The " { $vocab-link "colors" } " vocabulary defines a protocol for colors, with a concrete implementation for RGBA colors. This vocabulary is used by " { $vocab-link "io.styles" } ", " { $vocab-link "ui" } " and other vocabularies, but it is independent of them."
 $nl
-"RGBA colors:"
+"RGBA colors with floating point components in the range " { $snippet "[0,1]" } ":"
 { $subsection rgba }
 { $subsection <rgba> }
 "Converting a color to RGBA:"

basis/command-line/command-line.factor

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

basis/compiler/cfg/linear-scan/allocation/allocation.factor

@@ -99,7 +99,7 @@ SYMBOL: spill-counts
 : interval-to-spill ( active-intervals current -- live-interval )
     #! We spill the interval with the most distant use location.
     start>> '[ dup _ [ >= ] find-use nip ] { } map>assoc
-    unclip-slice [ [ [ second ] bi@ > ] most ] reduce first ;
+    [ ] [ [ [ second ] bi@ > ] most ] map-reduce first ;
 
 : assign-spill ( before after -- before after )
     #! If it has been spilled already, reuse spill location.

basis/compiler/tree/propagation/info/info.factor

@@ -238,7 +238,7 @@ DEFER: (value-info-union)
 
 : value-infos-union ( infos -- info )
     [ null-info ]
-    [ unclip-slice [ value-info-union ] reduce ] if-empty ;
+    [ [ ] [ value-info-union ] map-reduce ] if-empty ;
 
 : literals<= ( info1 info2 -- ? )
     {

basis/db/errors/sqlite/sqlite.factor

@@ -4,7 +4,8 @@ USING: accessors combinators db kernel sequences peg.ebnf
 strings db.errors ;
 IN: db.errors.sqlite
 
-ERROR: unparsed-sqlite-error error ;
+TUPLE: unparsed-sqlite-error error ;
+C: <unparsed-sqlite-error> unparsed-sqlite-error
 
 SINGLETONS: table-exists table-missing ;
 
@@ -22,4 +23,6 @@ SqliteError =
       => [[ table >string message sqlite-table-error ]]
     | "no such table: " .+:table
       => [[ table >string <sql-table-missing> ]]
+    | .*:error
+      => [[ error >string <unparsed-sqlite-error> ]]
 ;EBNF

basis/delegate/protocols/protocols.factor

@@ -1,7 +1,6 @@
 ! Copyright (C) 2007 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
-USING: delegate sequences.private sequences assocs
+USING: delegate sequences.private sequences assocs io ;
-io definitions kernel continuations ;
 IN: delegate.protocols
 
 PROTOCOL: sequence-protocol
@@ -19,7 +18,3 @@ stream-read-until ;
 
 PROTOCOL: output-stream-protocol
 stream-flush stream-write1 stream-write stream-nl ;
-
-PROTOCOL: definition-protocol
-where set-where forget uses
-synopsis* definer definition ;

basis/furnace/actions/actions.factor

@@ -9,6 +9,7 @@ http.server.responses
 furnace.utilities
 furnace.redirection
 furnace.conversations
+furnace.chloe-tags
 html.forms
 html.components
 html.components

basis/furnace/furnace.factor

@@ -17,7 +17,6 @@ USE: vocabs.loader
 "furnace.auth.providers.db" require
 "furnace.auth.providers.null" require
 "furnace.boilerplate" require
-"furnace.chloe-tags" require
 "furnace.conversations" require
 "furnace.db" require
 "furnace.json" require

basis/furnace/redirection/redirection.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors combinators namespaces fry urls http
+USING: kernel accessors combinators namespaces fry urls urls.secure
-http.server http.server.redirection http.server.responses
+http http.server http.server.redirection http.server.responses
 http.server.remapping http.server.filters furnace.utilities ;
 IN: furnace.redirection
 

basis/help/home/home.factor

@@ -21,7 +21,7 @@ M: apropos add-recent-where recent-searches ;
 M: object add-recent-where f ;
 
 : $recent ( element -- )
-    first get [ nl ] [ 1array $pretty-link ] interleave ;
+    first get reverse [ nl ] [ 1array $pretty-link ] interleave ;
 
 : $recent-searches ( element -- )
     drop recent-searches get [ <$link> ] map $list ;

basis/hints/hints.factor

@@ -25,7 +25,7 @@ M: object specializer-declaration class ;
     [ drop object eq? not ] assoc-filter
     [ [ t ] ] [
         [ swap specializer-predicate append ] { } assoc>map
-        unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
+        [ ] [ swap [ f ] \ if 3array append [ ] like ] map-reduce
     ] if-empty ;
 
 : specializer-cases ( quot word -- default alist )

basis/http/client/client.factor

@@ -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
+        response "location" header redirect-url
-        "GET" >>method swap (with-http-request)
+        response code>> 307 = [ "GET" >>method ] unless
+        quot (with-http-request)
     ] [ too-many-redirects ] if ; inline recursive
 
 : read-chunk-size ( -- n )

basis/http/http-tests.factor

@@ -1,8 +1,8 @@
-USING: http http.server http.client http.client.private tools.test multiline
+USING: http http.server http.client http.client.private tools.test
-io.streams.string io.encodings.utf8 io.encodings.8-bit
+multiline io.streams.string io.encodings.utf8 io.encodings.8-bit
-io.encodings.binary io.encodings.string kernel arrays splitting
+io.encodings.binary io.encodings.string io.encodings.ascii kernel
-sequences assocs io.sockets db db.sqlite continuations urls
+arrays splitting sequences assocs io.sockets db db.sqlite
-hashtables accessors namespaces xml.data ;
+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

basis/http/server/static/static.factor

@@ -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
+    [ file-responder get root>> trim-tail-separators ] dip
-    "" or trim-head-separators 3append ;
+    [ "/" swap trim-head-separators 3append ] unless-empty ;
 
 : serve-file ( filename -- response )
     dup mime-type

basis/io/streams/limited/limited-tests.factor

@@ -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

basis/io/streams/limited/limited.factor

@@ -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

basis/math/blas/config/config.factor

@@ -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   ] }

basis/opengl/textures/textures.factor

@@ -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 } }

basis/regexp/ast/ast.factor

@@ -21,12 +21,12 @@ CONSTANT: epsilon T{ tagged-epsilon { tag t } }
 TUPLE: concatenation first second ;
 
 : <concatenation> ( seq -- concatenation )
-    [ epsilon ] [ unclip [ concatenation boa ] reduce ] if-empty ;
+    [ epsilon ] [ [ ] [ concatenation boa ] map-reduce ] if-empty ;
 
 TUPLE: alternation first second ;
 
 : <alternation> ( seq -- alternation )
-    unclip [ alternation boa ] reduce ;
+    [ ] [ alternation boa ] map-reduce ;
 
 TUPLE: star term ;
 C: <star> star

basis/regexp/dfa/dfa.factor

@@ -51,10 +51,13 @@ IN: regexp.dfa
     [ condition-states ] 2dip
     '[ _ _ add-todo-state ] each ;
 
+: ensure-state ( key table -- )
+    2dup key? [ 2drop ] [ [ H{ } clone ] 2dip set-at ] if ; inline
+
 :: new-transitions ( nfa dfa new-states visited-states -- nfa dfa )
     new-states [ nfa dfa ] [
         pop :> state
-        state dfa transitions>> maybe-initialize-key
+        state dfa transitions>> ensure-state
         state nfa find-transitions
         [| trans |
             state trans nfa find-closure :> new-state

basis/regexp/transition-tables/transition-tables.factor

@@ -11,12 +11,7 @@ TUPLE: transition-table transitions start-state final-states ;
         H{ } clone >>transitions
         H{ } clone >>final-states ;
 
-: maybe-initialize-key ( key hashtable -- )
-    ! Why do we have to do this?
-    2dup key? [ 2drop ] [ [ H{ } clone ] 2dip set-at ] if ;
-
 :: (set-transition) ( from to obj hash -- )
-    to condition? [ to hash maybe-initialize-key ] unless
     from hash at
     [ [ to obj ] dip set-at ]
     [ to obj associate from hash set-at ] if* ;
@@ -25,7 +20,6 @@ TUPLE: transition-table transitions start-state final-states ;
     transitions>> (set-transition) ;
 
 :: (add-transition) ( from to obj hash -- )
-    to hash maybe-initialize-key
     from hash at
     [ [ to obj ] dip push-at ]
     [ to 1vector obj associate from hash set-at ] if* ;

basis/tools/deploy/backend/backend.factor

@@ -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 ;
 

basis/ui/backend/backend.factor

@@ -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
+    '[ select-gl-context @ ]
-    flush-gl-context gl-error ; inline
+    [ flush-gl-context gl-error ] bi ; inline
 
 HOOK: (with-ui) ui-backend ( quot -- )

basis/ui/gadgets/buttons/buttons-docs.factor

@@ -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" }

basis/ui/gadgets/worlds/worlds.factor

@@ -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
+namespaces opengl opengl.capabilities opengl.textures sequences io
-fry math.vectors math.rectangles cache ui.gadgets ui.gestures
+combinators combinators.short-circuit fry math.vectors math.rectangles
-ui.render ui.backend ui.gadgets.tracks ui.commands ;
+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 ]

basis/ui/ui.factor

@@ -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
+combinators combinators.short-circuit hashtables concurrency.flags
-destructors ui.gadgets ui.gadgets.private ui.gadgets.worlds
+sets accessors calendar fry destructors ui.gadgets ui.gadgets.private
-ui.gadgets.tracks ui.gestures ui.backend ui.render ;
+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
+    send-queued-gestures ;
-    ] [ ui-error ] recover ;
 
 SYMBOL: ui-thread
 
@@ -133,8 +131,7 @@ SYMBOL: ui-thread
 PRIVATE>
 
 : find-window ( quot -- world )
-    windows get values
+    [ windows get values ] dip '[ gadget-child @ ] find-last nip ; inline
-    [ gadget-child swap call ] with 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 ]
+    #! Note the logic: if update-ui fails, we open an error window
-    [ ui-notify-flag get lower-flag update-ui ]
+    #! and run one iteration of update-ui. If that also fails, well,
-    while ;
+    #! 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 ]

core/classes/builtin/builtin.factor

@@ -55,7 +55,7 @@ M: anonymous-intersection (flatten-class)
     [
         builtins get sift [ (flatten-class) ] each
     ] [
-        unclip [ assoc-intersect ] reduce [ swap set ] assoc-each
+        [ ] [ assoc-intersect ] map-reduce [ swap set ] assoc-each
     ] if-empty ;
 
 M: anonymous-complement (flatten-class)

extra/benchmark/fib6/deploy.factor

@@ -0,0 +1,15 @@
+USING: tools.deploy.config ;
+H{
+    { deploy-name "benchmark.fib6" }
+    { deploy-threads? f }
+    { deploy-math? f }
+    { deploy-word-props? f }
+    { deploy-ui? f }
+    { deploy-io 1 }
+    { deploy-compiler? t }
+    { deploy-reflection 1 }
+    { "stop-after-last-window?" t }
+    { deploy-unicode? f }
+    { deploy-word-defs? f }
+    { deploy-c-types? f }
+}

extra/descriptive/descriptive-docs.factor

@@ -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
+HELP: descriptive-error
-{ $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)." } ;
+{ $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:"
+"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 }
+{ $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:: } ;

extra/descriptive/descriptive.factor

@@ -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 ]

extra/id3/id3.factor

@@ -163,17 +163,13 @@ TUPLE: id3v1-info title artist album year comment genre ;
         } cond
     ] with-mapped-uchar-file ;
 
-: (find-id3-frame) ( id3 name quot: ( obj -- obj' ) -- obj' )
-    [ swap frames>> at* ] dip
-    [ data>> ] prepose [ drop f ] if ; inline
-
 PRIVATE>
 
 : mp3>id3 ( path -- id3v2-info/f )
     dup file-info size>> 0 <= [ drop f ] [ (mp3>id3) ] if ; inline
 
 : find-id3-frame ( id3 name -- obj/f )
-    [ ] (find-id3-frame) ; inline
+    swap frames>> at* [ data>> ] when ; inline
 
 : title ( id3 -- title/f ) "TIT2" find-id3-frame ; inline
 
@@ -186,7 +182,7 @@ PRIVATE>
 : comment ( id3 -- comment/f ) "COMM" find-id3-frame ; inline
 
 : genre ( id3 -- genre/f )
-    "TCON" [ parse-genre ] (find-id3-frame) ; inline
+    "TCON" find-id3-frame parse-genre ; inline
 
 : find-mp3s ( path -- seq )
     [ >lower ".mp3" tail? ] find-all-files ; inline

extra/poker/poker-docs.factor

@@ -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." } ;

extra/poker/poker-tests.factor

@@ -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

extra/poker/poker.factor

@@ -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 perfect-hash-find ]
-            prime-bits products-table sorted-index
-            values-table nth
-        ]
     } 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 ;

extra/project-euler/007/007.factor

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

extra/project-euler/054/054.factor

@@ -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

extra/project-euler/058/058-tests.factor

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

extra/project-euler/058/058.factor

@@ -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

extra/project-euler/063/063-tests.factor

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

extra/project-euler/063/063.factor

@@ -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

extra/project-euler/069/069-tests.factor

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

extra/project-euler/069/069.factor

@@ -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

extra/project-euler/071/071.factor

@@ -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 ;

extra/project-euler/common/common.factor

@@ -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
+USING: accessors arrays kernel lists make math math.functions math.matrices
-    math.order math.parser math.primes.factors math.ranges math.ratios
+    math.miller-rabin math.order math.parser math.primes.factors
-    sequences sorting strings unicode.case parser accessors vocabs.parser
+    math.primes.lists math.ranges math.ratios namespaces parser prettyprint
-    namespaces vocabs words quotations 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 )

extra/project-euler/project-euler.factor

@@ -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.055 project-euler.056 project-euler.057 project-euler.058
-    project-euler.067 project-euler.071 project-euler.073 project-euler.075
+    project-euler.059 project-euler.063 project-euler.067 project-euler.069
-    project-euler.076 project-euler.079 project-euler.092 project-euler.097
+    project-euler.071 project-euler.073 project-euler.075 project-euler.076
-    project-euler.099 project-euler.100 project-euler.116 project-euler.117
+    project-euler.079 project-euler.092 project-euler.097 project-euler.099
-    project-euler.134 project-euler.148 project-euler.150 project-euler.151
+    project-euler.100 project-euler.116 project-euler.117 project-euler.134
-    project-euler.164 project-euler.169 project-euler.173 project-euler.175
+    project-euler.148 project-euler.150 project-euler.151 project-euler.164
-    project-euler.186 project-euler.190 project-euler.203 project-euler.215 ;
+    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

extra/robots/robots-tests.factor

@@ -1,26 +1,27 @@
 ! 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" }
+    { "http://www.chiplist.com/sitemap.txt" }
-{
+    {
         T{ rules
             { user-agents V{ "*" } }
             { allows V{ } }
             { disallows
                 V{
-                "/cgi-bin/"
+                    URL" /cgi-bin/"
-                "/scripts/"
+                    URL" /scripts/"
-                "/ChipList2/scripts/"
+                    URL" /ChipList2/scripts/"
-                "/ChipList2/styles/"
+                    URL" /ChipList2/styles/"
-                "/ads/"
+                    URL" /ads/"
-                "/ChipList2/ads/"
+                    URL" /ChipList2/ads/"
-                "/advertisements/"
+                    URL" /advertisements/"
-                "/ChipList2/advertisements/"
+                    URL" /ChipList2/advertisements/"
-                "/graphics/"
+                    URL" /graphics/"
-                "/ChipList2/graphics/"
+                    URL" /ChipList2/graphics/"
                 }
             }
             { visit-time
@@ -36,163 +37,163 @@ IN: robots.tests
         T{ rules
             { user-agents V{ "UbiCrawler" } }
             { allows V{ } }
-        { disallows V{ "/" } }
+            { disallows V{ URL" /" } }
             { unknowns H{ } }
         }
         T{ rules
             { user-agents V{ "DOC" } }
             { allows V{ } }
-        { disallows V{ "/" } }
+            { disallows V{ URL" /" } }
             { unknowns H{ } }
         }
         T{ rules
             { user-agents V{ "Zao" } }
             { allows V{ } }
-        { disallows V{ "/" } }
+            { disallows V{ URL" /" } }
             { unknowns H{ } }
         }
         T{ rules
             { user-agents V{ "sitecheck.internetseer.com" } }
             { allows V{ } }
-        { disallows V{ "/" } }
+            { disallows V{ URL" /" } }
             { unknowns H{ } }
         }
         T{ rules
             { user-agents V{ "Zealbot" } }
             { allows V{ } }
-        { disallows V{ "/" } }
+            { disallows V{ URL" /" } }
             { unknowns H{ } }
         }
         T{ rules
             { user-agents V{ "MSIECrawler" } }
             { allows V{ } }
-        { disallows V{ "/" } }
+            { disallows V{ URL" /" } }
             { unknowns H{ } }
         }
         T{ rules
             { user-agents V{ "SiteSnagger" } }
             { allows V{ } }
-        { disallows V{ "/" } }
+            { disallows V{ URL" /" } }
             { unknowns H{ } }
         }
         T{ rules
             { user-agents V{ "WebStripper" } }
             { allows V{ } }
-        { disallows V{ "/" } }
+            { disallows V{ URL" /" } }
             { unknowns H{ } }
         }
         T{ rules
             { user-agents V{ "WebCopier" } }
             { allows V{ } }
-        { disallows V{ "/" } }
+            { disallows V{ URL" /" } }
             { unknowns H{ } }
         }
         T{ rules
             { user-agents V{ "Fetch" } }
             { allows V{ } }
-        { disallows V{ "/" } }
+            { disallows V{ URL" /" } }
             { unknowns H{ } }
         }
         T{ rules
             { user-agents V{ "Offline Explorer" } }
             { allows V{ } }
-        { disallows V{ "/" } }
+            { disallows V{ URL" /" } }
             { unknowns H{ } }
         }
         T{ rules
             { user-agents V{ "Teleport" } }
             { allows V{ } }
-        { disallows V{ "/" } }
+            { disallows V{ URL" /" } }
             { unknowns H{ } }
         }
         T{ rules
             { user-agents V{ "TeleportPro" } }
             { allows V{ } }
-        { disallows V{ "/" } }
+            { disallows V{ URL" /" } }
             { unknowns H{ } }
         }
         T{ rules
             { user-agents V{ "WebZIP" } }
             { allows V{ } }
-        { disallows V{ "/" } }
+            { disallows V{ URL" /" } }
             { unknowns H{ } }
         }
         T{ rules
             { user-agents V{ "linko" } }
             { allows V{ } }
-        { disallows V{ "/" } }
+            { disallows V{ URL" /" } }
             { unknowns H{ } }
         }
         T{ rules
             { user-agents V{ "HTTrack" } }
             { allows V{ } }
-        { disallows V{ "/" } }
+            { disallows V{ URL" /" } }
             { unknowns H{ } }
         }
         T{ rules
             { user-agents V{ "Microsoft.URL.Control" } }
             { allows V{ } }
-        { disallows V{ "/" } }
+            { disallows V{ URL" /" } }
             { unknowns H{ } }
         }
         T{ rules
             { user-agents V{ "Xenu" } }
             { allows V{ } }
-        { disallows V{ "/" } }
+            { disallows V{ URL" /" } }
             { unknowns H{ } }
         }
         T{ rules
             { user-agents V{ "larbin" } }
             { allows V{ } }
-        { disallows V{ "/" } }
+            { disallows V{ URL" /" } }
             { unknowns H{ } }
         }
         T{ rules
             { user-agents V{ "libwww" } }
             { allows V{ } }
-        { disallows V{ "/" } }
+            { disallows V{ URL" /" } }
             { unknowns H{ } }
         }
         T{ rules
             { user-agents V{ "ZyBORG" } }
             { allows V{ } }
-        { disallows V{ "/" } }
+            { disallows V{ URL" /" } }
             { unknowns H{ } }
         }
         T{ rules
             { user-agents V{ "Download Ninja" } }
             { allows V{ } }
-        { disallows V{ "/" } }
+            { disallows V{ URL" /" } }
             { unknowns H{ } }
         }
         T{ rules
             { user-agents V{ "wget" } }
             { allows V{ } }
-        { disallows V{ "/" } }
+            { disallows V{ URL" /" } }
             { unknowns H{ } }
         }
         T{ rules
             { user-agents V{ "grub-client" } }
             { allows V{ } }
-        { disallows V{ "/" } }
+            { disallows V{ URL" /" } }
             { unknowns H{ } }
         }
         T{ rules
             { user-agents V{ "k2spider" } }
             { allows V{ } }
-        { disallows V{ "/" } }
+            { disallows V{ URL" /" } }
             { unknowns H{ } }
         }
         T{ rules
             { user-agents V{ "NPBot" } }
             { allows V{ } }
-        { disallows V{ "/" } }
+            { disallows V{ URL" /" } }
             { unknowns H{ } }
         }
         T{ rules
             { user-agents V{ "WebReaper" } }
             { allows V{ } }
-        { disallows V{ "/" } }
+            { disallows V{ URL" /" } }
             { unknowns H{ } }
         }
         T{ rules
@@ -327,8 +328,8 @@ IN: robots.tests
                 }
             }
             { allows V{ } }
-        { disallows V{ "/" } }
+            { disallows V{ URL" /" } }
             { unknowns H{ } }
         }
-}
+    }
 ] [ "vocab:robots/robots.txt" utf8 file-contents parse-robots.txt ] unit-test

extra/robots/robots.factor

@@ -3,11 +3,21 @@
 USING: accessors http.client kernel unicode.categories
 sequences urls splitting combinators splitting.monotonic
 combinators.short-circuit assocs unicode.case arrays
-math.parser calendar.format make ;
+math.parser calendar.format make fry present globs
+multiline regexp.combinators regexp ;
 IN: robots
 
 ! visit-time is GMT, request-rate is pages/second 
 ! crawl-rate is seconds
+
+TUPLE: robots site sitemap rules rules-quot ;
+
+: <robots> ( site sitemap rules -- robots )
+    \ robots new
+        swap >>rules
+        swap >>sitemap
+        swap >>site ;
+
 TUPLE: rules user-agents allows disallows
 visit-time request-rate crawl-delay unknowns ;
 
@@ -40,8 +50,8 @@ visit-time request-rate crawl-delay unknowns ;
         H{ } clone >>unknowns ;
 
 : add-user-agent ( rules agent -- rules ) over user-agents>> push ;
-: add-allow ( rules allow -- rules ) over allows>> push ;
+: add-allow ( rules allow -- rules ) >url over allows>> push ;
-: add-disallow ( rules disallow -- rules ) over disallows>> push ;
+: add-disallow ( rules disallow -- rules ) >url over disallows>> push ;
 
 : parse-robots.txt-line ( rules seq -- rules )
     first2 swap {
@@ -57,6 +67,19 @@ visit-time request-rate crawl-delay unknowns ;
         [ pick unknowns>> push-at ]
     } case ;
 
+: derive-urls ( url seq -- seq' )
+    [ derive-url present ] with { } map-as ;
+
+: robot-rules-quot ( robots -- quot )
+    [
+        [ site>> ] [ rules>> allows>> ] bi
+        derive-urls [ <glob> ] map
+        <or>
+    ] [
+        [ site>> ] [ rules>> disallows>> ] bi
+        derive-urls [ <glob> ] map <and> <not>
+    ] bi 2array <or> '[ _ matches? ] ;
+
 PRIVATE>
 
 : parse-robots.txt ( string -- sitemaps rules-seq )
@@ -64,5 +87,6 @@ PRIVATE>
         [ <rules> dup ] dip [ parse-robots.txt-line drop ] with each
     ] map ;
 
-: robots ( url -- sitemaps rules-seq )
+: robots ( url -- robots )
-    get-robots.txt nip parse-robots.txt ;
+    >url
+    dup get-robots.txt nip parse-robots.txt <robots> ;

extra/site-watcher/db/db.factor

@@ -2,10 +2,10 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors continuations db db.sqlite db.tuples db.types
 io.directories io.files.temp kernel io.streams.string calendar
-debugger combinators.smart sequences ;
+debugger combinators.smart sequences arrays ;
 IN: site-watcher.db
 
-TUPLE: account account-id account-name email twitter sms ;
+TUPLE: account account-name email twitter sms ;
 
 : <account> ( account-name email -- account )
     account new
@@ -25,6 +25,12 @@ TUPLE: site site-id url up? changed? last-up error last-error ;
     site new
         swap >>url ;
 
+: site-with-url ( url -- site )
+    <site> select-tuple ;
+
+: site-with-id ( id -- site )
+    site new swap >>site-id select-tuple ;
+
 site "SITE" {
     { "site-id" "SITE_ID" INTEGER +db-assigned-id+ }
     { "url" "URL" VARCHAR }
@@ -47,9 +53,41 @@ watching-site "WATCHING_SITE" {
     { "site-id" "SITE_ID" INTEGER +user-assigned-id+ }
 } define-persistent
 
-TUPLE: reporting-site email url up? changed? last-up? error last-error ;
+TUPLE: spidering-site < watching-site max-depth max-count ;
 
-<PRIVATE
+C: <spidering-site> spidering-site
+
+SLOT: site
+
+M: watching-site site>>
+    site-id>> site-with-id ;
+
+SLOT: account
+
+M: watching-site account>>
+    account-name>> account new swap >>account-name select-tuple ;
+
+spidering-site "SPIDERING_SITE" {
+    { "max-depth" "MAX_DEPTH" INTEGER }
+    { "max-count" "MAX_COUNT" INTEGER }
+} define-persistent
+
+: spidering-sites ( username -- sites )
+    spidering-site new swap >>account-name select-tuples ;
+
+: insert-site ( url -- site )
+    <site> dup select-tuple [ ] [ dup t >>up? insert-tuple ] ?if ;
+
+: select-account/site ( username url -- account site )
+    insert-site site-id>> ;
+
+: add-spidered-site ( username url -- )
+    select-account/site 10 10 <spidering-site> insert-tuple ;
+
+: remove-spidered-site ( username url -- )
+    select-account/site 10 10 <spidering-site> delete-tuples ;
+
+TUPLE: reporting-site site-id email url up? changed? last-up? error last-error ;
 
 : set-notify-site-watchers ( site new-up? -- site )
     [ over up?>> = [ t >>changed? ] unless ] keep >>up? ;
@@ -72,18 +110,10 @@ TUPLE: reporting-site email url up? changed? last-up? error last-error ;
     [ [ reporting-site boa ] input<sequence ] map
     "update site set changed = 0;" sql-command ;
 
-: insert-site ( url -- site )
-    <site> dup select-tuple [ ] [ dup t >>up? insert-tuple ] ?if ;
-
 : insert-account ( account-name email -- ) <account> insert-tuple ;
 
 : find-sites ( -- seq ) f <site> select-tuples ;
 
-: select-account/site ( username url -- account site )
-    insert-site site-id>> ;
-
-PRIVATE>
-
 : watch-site ( username url -- )
     select-account/site <watching-site> insert-tuple ;
 

extra/site-watcher/email/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/site-watcher/email/email.factor

@@ -0,0 +1,14 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: smtp namespaces accessors kernel arrays ;
+IN: site-watcher.email
+
+SYMBOL: site-watcher-from
+site-watcher-from [ "factor-site-watcher@gmail.com" ] initialize
+
+: send-site-email ( watching-site body subject -- )
+    [ account>> email>> ] 2dip
+    pick [
+        [ <email> site-watcher-from get >>from ] 3dip
+        [ 1array >>to ] [ >>body ] [ >>subject ] tri* send-email 
+    ] [ 3drop ] if ;

extra/site-watcher/site-watcher-tests.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: db.tuples locals site-watcher site-watcher.db
 site-watcher.private kernel db io.directories io.files.temp
-continuations site-watcher.db.private db.sqlite
+continuations db.sqlite
 sequences tools.test ;
 IN: site-watcher.tests
 

extra/site-watcher/site-watcher.factor

@@ -3,13 +3,9 @@
 USING: accessors alarms arrays calendar combinators
 combinators.smart continuations debugger http.client fry
 init io.streams.string kernel locals math math.parser db
-namespaces sequences site-watcher.db site-watcher.db.private
+namespaces sequences site-watcher.db site-watcher.email ;
-smtp ;
 IN: site-watcher
 
-SYMBOL: site-watcher-from
-"factor-site-watcher@gmail.com" site-watcher-from set-global
-
 SYMBOL: site-watcher-frequency
 5 minutes site-watcher-frequency set-global
  
@@ -23,34 +19,31 @@ SYMBOL: running-site-watcher
         [ dup url>> http-get 2drop site-good ] [ site-bad ] recover
     ] each ;
 
-: site-up-email ( email site -- email )
+: site-up-email ( site -- body )
     last-up>> now swap time- duration>minutes 60 /mod
     [ >integer number>string ] bi@
     [ " hours, " append ] [ " minutes" append ] bi* append
-    "Site was down for (at least): " prepend >>body ;
+    "Site was down for (at least): " prepend ;
 
-: site-down-email ( email site -- email ) error>> >>body ;
+: site-down-email ( site -- body ) error>> ;
 
 : send-report ( site -- )
-    [ <email> ] dip
+    [ ]
-    {
-        [ email>> 1array >>to ]
-        [ drop site-watcher-from get "factor.site.watcher@gmail.com" or >>from ]
     [ dup up?>> [ site-up-email ] [ site-down-email ] if ]
-        [ [ url>> ] [ up?>> "up" "down" ? ] bi " is " glue >>subject ]
+    [ [ url>> ] [ up?>> "up" "down" ? ] bi " is " glue ] tri
-    } cleave send-email ;
+    send-site-email ;
 
 : send-reports ( seq -- )
     [ ] [ [ send-report ] each ] if-empty ;
 
 PRIVATE>
 
-: watch-sites ( db -- )
+: watch-sites ( -- )
-    [ find-sites check-sites sites-to-report send-reports ] with-db ;
+    find-sites check-sites sites-to-report send-reports ;
 
 : run-site-watcher ( db -- )
     [ running-site-watcher get ] dip '[ 
-        [ _ watch-sites ] site-watcher-frequency get every
+        [ _ [ watch-sites ] with-db ] site-watcher-frequency get every
         running-site-watcher set
     ] unless ;
 

extra/site-watcher/spider/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/site-watcher/spider/spider.factor

@@ -0,0 +1,25 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: site-watcher.db site-watcher.email site-watcher.spider
+spider spider.report
+accessors kernel sequences
+xml.writer concurrency.combinators ;
+IN: site-watcher.spider
+
+: <site-spider> ( spidering-site -- spider )
+    [ max-depth>> ]
+    [ max-count>> ]
+    [ site>> url>> ]
+    tri
+    <spider>
+        swap >>max-count
+        swap >>max-depth ;
+
+: spider-and-email ( spidering-site -- )
+    [ ]
+    [ <site-spider> run-spider spider-report xml>string ]
+    [ site>> url>> "Spidered " prefix ] tri
+    send-site-email ;
+
+: spider-sites ( -- )
+    f spidering-sites [ spider-and-email ] parallel-each ;

extra/spider/report/report.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs combinators kernel math
 math.statistics namespaces sequences sorting xml.syntax
-spider ;
+spider urls html ;
 IN: spider.report
 
 SYMBOL: network-failures
@@ -39,10 +39,11 @@ SYMBOL: time-std
     timings get sort-values
     [ slowest short tail* reverse slowest-pages set ]
     [
-        values
+        values [
             [ mean 1000000 /f mean-time set ]
             [ median 1000000 /f median-time set ]
             [ std 1000000 /f time-std set ] tri
+        ] unless-empty
     ] bi ;
 
 : process-results ( results -- )
@@ -87,27 +88,37 @@ SYMBOL: time-std
     slowest-pages-table
     timing-summary-table
     [XML
-    <h2>Slowest pages</h2>
+    <h3>Slowest pages</h3>
     <->
 
-    <h2>Summary</h2>
+    <h3>Summary</h3>
     <->
     XML] ;
 
 : generate-report ( -- html )
+    url get dup
     report-broken-pages
     report-network-failures
     report-timings
     [XML
-    <h1>Broken pages</h1>
+    <h1>Spider report</h1>
+    URL: <a href=<->><-></a>
+
+    <h2>Broken pages</h2>
     <->
 
-    <h1>Network failures</h1>
+    <h2>Network failures</h2>
     <->
 
-    <h1>Load times</h1>
+    <h2>Load times</h2>
     <->
     XML] ;
 
 : spider-report ( spider -- html )
-    [ spidered>> process-results generate-report ] with-scope ;
+    [ "Spider report" f ] dip
+    [
+        [ base>> url set ]
+        [ spidered>> process-results ] bi
+        generate-report
+    ] with-scope
+    simple-page ;

extra/spider/spider.factor

@@ -5,12 +5,12 @@ 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
-spider.unique-deque ;
+spider.unique-deque combinators concurrency.semaphores ;
 IN: spider
 
 TUPLE: spider base count max-count sleep max-depth initial-links
 filters spidered todo nonmatching quiet currently-spidering
-#threads follow-robots? robots ;
+#threads semaphore follow-robots? robots ;
 
 TUPLE: spider-result url depth headers
 fetched-in parsed-html links processed-in fetched-at ;
@@ -26,7 +26,12 @@ fetched-in parsed-html links processed-in fetched-at ;
         0 >>count
         1/0. >>max-count
         H{ } clone >>spidered
-        1 >>#threads ;
+        1 [ >>#threads ] [ <semaphore> >>semaphore ] bi ;
+
+: <spider-result> ( url depth -- spider-result )
+    spider-result new
+        swap >>depth
+        swap >>url ;
 
 <PRIVATE
 
@@ -57,26 +62,32 @@ fetched-in parsed-html links processed-in fetched-at ;
 : normalize-hrefs ( base links -- links' )
     [ derive-url ] with map ;
 
-: print-spidering ( url depth -- )
+: print-spidering ( spider-result -- )
+    [ url>> ] [ depth>> ] bi
     "depth: " write number>string write
     ", spidering: " write . yield ;
 
-:: new-spidered-result ( spider url depth -- spider-result )
+:: fill-spidered-result ( spider spider-result -- )
-    f url spider spidered>> set-at
+    f spider-result url>> spider spidered>> set-at
-    [ url http-get ] benchmark :> fetched-at :> html :> headers
+    [ spider-result url>> http-get ] benchmark :> fetched-in :> html :> headers
     [
         html parse-html
         spider currently-spidering>>
         over find-all-links normalize-hrefs
-    ] benchmark :> processing-time :> links :> parsed-html
+    ] benchmark :> processed-in :> links :> parsed-html
-    url depth headers fetched-at parsed-html links processing-time
+    spider-result
-    now spider-result boa ;
+        headers >>headers
+        fetched-in >>fetched-in
+        parsed-html >>parsed-html
+        links >>links
+        processed-in >>processed-in
+        now >>fetched-at drop ;
 
-:: spider-page ( spider url depth -- )
+:: spider-page ( spider spider-result -- )
-    spider quiet>> [ url depth print-spidering ] unless
+    spider quiet>> [ spider-result print-spidering ] unless
-    spider url depth new-spidered-result :> spidered-result
+    spider spider-result fill-spidered-result
-    spider quiet>> [ spidered-result describe ] unless
+    spider quiet>> [ spider-result describe ] unless
-    spider spidered-result add-spidered ;
+    spider spider-result add-spidered ;
 
 \ spider-page ERROR add-error-logging
 
@@ -94,9 +105,9 @@ fetched-in parsed-html links processed-in fetched-at ;
         [ [ count>> ] [ max-count>> ] bi < ]
     } 1&& ;
 
-: setup-next-url ( spider -- spider url depth )
+: setup-next-url ( spider -- spider spider-result )
     dup todo>> peek-url url>> >>currently-spidering
-    dup todo>> pop-url [ url>> ] [ depth>> ] bi ;
+    dup todo>> pop-url [ url>> ] [ depth>> ] bi <spider-result> ;
 
 : spider-next-page ( spider -- )
     setup-next-url spider-page ;

extra/webapps/site-watcher/common/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/webapps/site-watcher/common/common.factor

@@ -0,0 +1,6 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: http.server.dispatchers ;
+IN: webapps.site-watcher.common
+
+TUPLE: site-watcher-app < dispatcher ;

extra/webapps/site-watcher/common/main.xml

@@ -0,0 +1,13 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+<p>SiteWatcher is a free service for web masters. It periodically tries fetching your web site via HTTP, and sends you an e-mail, SMS or Tweet if this fails. <t:a t:href="$site-watcher-app/login">Sign up now!</t:a></p>
+
+<ul>
+  <li><t:a t:href="$site-watcher-app/update-notify">Your contact info</t:a></li>
+  <li><t:a t:href="$site-watcher-app/watch-list">Watched sites</t:a></li>
+  <li><t:a t:href="$site-watcher-app/spider-list">Spidered sites</t:a></li>
+</ul>
+
+</t:chloe>

extra/webapps/site-watcher/common/site-list.xml

@@ -0,0 +1,28 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+<h1>Add some sites to watch</h1>
+
+<t:form t:action="$site-watcher-app/add-watch">
+<table>
+  <tr><th>URL:</th><td> <t:field t:name="url" t:size="80" /> <button type="submit">Done</button> </td></tr>
+</table>
+</t:form>
+
+<h1>Keep track of your sites</h1>
+
+<table border="2">
+  <tr> <th>URL</th><th></th> </tr>
+  <t:bind-each t:name="sites">
+    <tr>
+      <td> <t:label t:name="url" /> </td>
+      <td> <t:button t:action="$site-watcher-app/remove-watch" t:for="url">Remove</t:button> </td>
+    </tr>
+  </t:bind-each>
+</table>
+<p>
+  <t:button t:action="$site-watcher-app/check">Check now</t:button>
+</p>
+
+</t:chloe>

extra/webapps/site-watcher/common/spider-list.xml

@@ -0,0 +1,28 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+<h1>Add a site to spider</h1>
+
+<t:form t:action="$site-watcher-app/add-spider">
+<table>
+  <tr><th>URL:</th><td> <t:field t:name="url" t:size="80" /> <button type="submit">Done</button> </td></tr>
+</table>
+</t:form>
+
+<h1>Spidered sites</h1>
+
+<table border="2">
+  <tr> <th>URL</th><th></th> </tr>
+  <t:bind-each t:name="sites">
+    <tr>
+      <td> <t:label t:name="url" /> </td>
+      <td> <t:button t:action="$site-watcher-app/remove-spider" t:for="url">Remove</t:button> </td>
+    </tr>
+  </t:bind-each>
+</table>
+<p>
+  <t:button t:action="$site-watcher-app/spider">Spider now</t:button>
+</p>
+
+</t:chloe>

extra/webapps/site-watcher/main.xml

@@ -1,7 +0,0 @@
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
-<p>SiteWatcher is a free service for web masters. It periodically tries fetching your web site via HTTP, and sends you an e-mail, SMS or Tweet if this fails. <t:a t:href="$site-watcher-app/list">Sign up now!</t:a></p>
-
-</t:chloe>

extra/webapps/site-watcher/site-list.xml

@@ -1,32 +0,0 @@
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
-<p> Don't you hate it when your web site goes down, and all your users go buy that <a href="http://en.wikipedia.org/wiki/Slanket">slanket</a> from your competitor instead. Now using SiteWatcher, you can ensure this will never happen again! </p>
-
-<t:a t:href="$site-watcher-app/update-notify">Contact info</t:a>
-
-<h3>Step 2: add some sites to watch</h3>
-
-<t:form t:action="$site-watcher-app/add">
-<table>
-  <tr><th>URL:</th><td> <t:field t:name="url" t:size="80" /> <button type="submit">Done</button> </td></tr>
-</table>
-</t:form>
-
-<h3>Step 3: keep track of your sites</h3>
-
-<table border="2">
-  <tr> <th>URL</th><th></th> </tr>
-  <t:bind-each t:name="sites">
-    <tr>
-      <td> <t:label t:name="url" /> </td>
-      <td> <t:button t:action="$site-watcher-app/remove" t:for="url">Remove</t:button> </td>
-    </tr>
-  </t:bind-each>
-</table>
-<p>
-  <t:button t:action="$site-watcher-app/check">Check now</t:button>
-</p>
-
-</t:chloe>

extra/webapps/site-watcher/site-watcher.factor

@@ -8,65 +8,14 @@ furnace.auth.features.registration furnace.auth.login
 furnace.boilerplate furnace.redirection html.forms http.server
 http.server.dispatchers kernel namespaces site-watcher site-watcher.db
 site-watcher.private urls validators io.sockets.secure.unix.debug
-io.servers.connection db db.tuples sequences ;
+io.servers.connection db db.tuples sequences webapps.site-watcher.common
+webapps.site-watcher.watching webapps.site-watcher.spidering ;
 QUALIFIED: assocs
 IN: webapps.site-watcher
 
-TUPLE: site-watcher-app < dispatcher ;
-
-CONSTANT: site-list-url URL" $site-watcher-app/"
-
 : <main-action> ( -- action )
     <page-action>
-        [
+        { site-watcher-app "main" } >>template ;
-            logged-in?
-            [ URL" $site-watcher-app/list" <redirect> ]
-            [ { site-watcher-app "main" } <chloe-content> ] if
-        ] >>display ;
-
-: <site-list-action> ( -- action )
-    <page-action>
-        { site-watcher-app "site-list" } >>template
-        [
-            ! Silly query
-            username watching-sites
-            "sites" set-value
-        ] >>init
-    <protected>
-        "list watched sites" >>description ;
-
-: <add-site-action> ( -- action )
-    <action>
-        [
-            { { "url" [ v-url ] } } validate-params
-        ] >>validate
-        [
-            username "url" value watch-site
-            site-list-url <redirect>
-        ] >>submit
-    <protected>
-        "add a watched site" >>description ;
-
-: <remove-site-action> ( -- action )
-    <action>
-        [
-            { { "url" [ v-url ] } } validate-params
-        ] >>validate
-        [
-            username "url" value unwatch-site
-            site-list-url <redirect>
-        ] >>submit
-    <protected>
-        "remove a watched site" >>description ;
-
-: <check-sites-action> ( -- action )
-    <action>
-        [
-            watch-sites
-            site-list-url <redirect>
-        ] >>submit
-    <protected>
-        "check watched sites" >>description ;
 
 : <update-notify-action> ( -- action )
     <page-action>
@@ -95,10 +44,14 @@ CONSTANT: site-list-url URL" $site-watcher-app/"
 : <site-watcher-app> ( -- dispatcher )
     site-watcher-app new-dispatcher
         <main-action> "" add-responder
-        <site-list-action> "list" add-responder
+        <watch-list-action> "watch-list" add-responder
-        <add-site-action> "add" add-responder
+        <add-watched-site-action> "add-watch" add-responder
-        <remove-site-action> "remove" add-responder
+        <remove-watched-site-action> "remove-watch" add-responder
         <check-sites-action> "check" add-responder
+        <spider-list-action> "spider-list" add-responder
+        <add-spidered-site-action> "add-spider" add-responder
+        <remove-spidered-site-action> "remove-spider" add-responder
+        <spider-sites-action> "spider" add-responder
         <update-notify-action> "update-notify" add-responder ;
 
 : <login-config> ( responder -- responder' )
@@ -125,12 +78,13 @@ site-watcher-db <alloy>
 main-responder set-global
 
 M: site-watcher-app init-user-profile
-    drop
+    drop B
     "username" value "email" value <account> insert-tuple ;
 
 : init-db ( -- )
     site-watcher-db [
-        { site account watching-site } [ ensure-table ] each
+        { site account watching-site spidering-site }
+        [ ensure-table ] each
     ] with-db ;
 
 : start-site-watcher ( -- )

extra/webapps/site-watcher/spidering/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/webapps/site-watcher/spidering/spidering.factor

@@ -0,0 +1,52 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors furnace.actions furnace.auth
+furnace.redirection html.forms validators webapps.site-watcher.common
+site-watcher.db site-watcher.spider kernel urls sequences ;
+IN: webapps.site-watcher.spidering
+
+CONSTANT: site-list-url URL" $site-watcher-app/spider-list"
+
+: <spider-list-action> ( -- action )
+    <page-action>
+        { site-watcher-app "spider-list" } >>template
+        [
+            ! Silly query
+            username B spidering-sites [ site>> ] map
+            "sites" set-value
+        ] >>init
+    <protected>
+        "list spidered sites" >>description ;
+
+: <add-spidered-site-action> ( -- action )
+    <action>
+        [
+            { { "url" [ v-url ] } } validate-params
+        ] >>validate
+        [
+            username "url" value add-spidered-site
+            site-list-url <redirect>
+        ] >>submit
+    <protected>
+        "add a spidered site" >>description ;
+
+: <remove-spidered-site-action> ( -- action )
+    <action>
+        [
+            { { "url" [ v-url ] } } validate-params
+        ] >>validate
+        [
+            username "url" value remove-spidered-site
+            site-list-url <redirect>
+        ] >>submit
+    <protected>
+        "remove a spidered site" >>description ;
+
+: <spider-sites-action> ( -- action )
+    <action>
+        [
+            spider-sites
+            site-list-url <redirect>
+        ] >>submit
+    <protected>
+        "spider sites" >>description ;

extra/webapps/site-watcher/watching/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/webapps/site-watcher/watching/watching.factor

@@ -0,0 +1,52 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors furnace.actions furnace.auth
+furnace.redirection html.forms site-watcher site-watcher.db
+validators webapps.site-watcher.common urls ;
+IN: webapps.site-watcher.watching
+
+CONSTANT: site-list-url URL" $site-watcher-app/watch-list"
+
+: <watch-list-action> ( -- action )
+    <page-action>
+        { site-watcher-app "site-list" } >>template
+        [
+            ! Silly query
+            username watching-sites
+            "sites" set-value
+        ] >>init
+    <protected>
+        "list watched sites" >>description ;
+
+: <add-watched-site-action> ( -- action )
+    <action>
+        [
+            { { "url" [ v-url ] } } validate-params
+        ] >>validate
+        [
+            username "url" value watch-site
+            site-list-url <redirect>
+        ] >>submit
+    <protected>
+        "add a watched site" >>description ;
+
+: <remove-watched-site-action> ( -- action )
+    <action>
+        [
+            { { "url" [ v-url ] } } validate-params
+        ] >>validate
+        [
+            username "url" value unwatch-site
+            site-list-url <redirect>
+        ] >>submit
+    <protected>
+        "remove a watched site" >>description ;
+
+: <check-sites-action> ( -- action )
+    <action>
+        [
+            watch-sites
+            site-list-url <redirect>
+        ] >>submit
+    <protected>
+        "check watched sites" >>description ;