Merge branch 'master' into smarter_error_list
Slava Pestov
commit
61918ac0c5
2
Makefile
2
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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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:"
|
||||
|
|
|
|||
|
|
@ -60,7 +60,6 @@ SYMBOL: main-vocab-hook
|
|||
: default-cli-args ( -- )
|
||||
global [
|
||||
"quiet" off
|
||||
"script" off
|
||||
"e" off
|
||||
"user-init" on
|
||||
embedded? "quiet" set
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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 -- ? )
|
||||
{
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
! Copyright (C) 2007 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: delegate sequences.private sequences assocs
|
||||
io definitions kernel continuations ;
|
||||
USING: delegate sequences.private sequences assocs io ;
|
||||
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 ;
|
||||
|
|
|
|||
|
|
@ -9,6 +9,7 @@ http.server.responses
|
|||
furnace.utilities
|
||||
furnace.redirection
|
||||
furnace.conversations
|
||||
furnace.chloe-tags
|
||||
html.forms
|
||||
html.components
|
||||
html.components
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
http.server http.server.redirection http.server.responses
|
||||
USING: kernel accessors combinators namespaces fry urls urls.secure
|
||||
http http.server http.server.redirection http.server.responses
|
||||
http.server.remapping http.server.filters furnace.utilities ;
|
||||
IN: furnace.redirection
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ math.order hashtables byte-arrays destructors
|
|||
io io.sockets io.streams.string io.files io.timeouts
|
||||
io.pathnames io.encodings io.encodings.string io.encodings.ascii
|
||||
io.encodings.utf8 io.encodings.8-bit io.encodings.binary io.crlf
|
||||
io.streams.duplex fry ascii urls urls.encoding present
|
||||
io.streams.duplex fry ascii urls urls.encoding present locals
|
||||
http http.parsers http.client.post-data ;
|
||||
IN: http.client
|
||||
|
||||
|
|
@ -77,12 +77,13 @@ SYMBOL: redirects
|
|||
: redirect? ( response -- ? )
|
||||
code>> 300 399 between? ;
|
||||
|
||||
: do-redirect ( quot: ( chunk -- ) response -- response )
|
||||
:: do-redirect ( quot: ( chunk -- ) response -- response )
|
||||
redirects inc
|
||||
redirects get max-redirects < [
|
||||
request get clone
|
||||
swap "location" header redirect-url
|
||||
"GET" >>method swap (with-http-request)
|
||||
response "location" header redirect-url
|
||||
response code>> 307 = [ "GET" >>method ] unless
|
||||
quot (with-http-request)
|
||||
] [ too-many-redirects ] if ; inline recursive
|
||||
|
||||
: read-chunk-size ( -- n )
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
USING: http http.server http.client http.client.private tools.test multiline
|
||||
io.streams.string io.encodings.utf8 io.encodings.8-bit
|
||||
io.encodings.binary io.encodings.string kernel arrays splitting
|
||||
sequences assocs io.sockets db db.sqlite continuations urls
|
||||
hashtables accessors namespaces xml.data ;
|
||||
USING: http http.server http.client http.client.private tools.test
|
||||
multiline io.streams.string io.encodings.utf8 io.encodings.8-bit
|
||||
io.encodings.binary io.encodings.string io.encodings.ascii kernel
|
||||
arrays splitting sequences assocs io.sockets db db.sqlite
|
||||
continuations urls hashtables accessors namespaces xml.data ;
|
||||
IN: http.tests
|
||||
|
||||
[ "text/plain" latin1 ] [ "text/plain" parse-content-type ] unit-test
|
||||
|
|
@ -359,4 +359,37 @@ SYMBOL: a
|
|||
! Test basic auth
|
||||
[ "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" ] [ <request> "Aladdin" "open sesame" set-basic-auth "Authorization" header ] unit-test
|
||||
|
||||
! Test a corner case with static responder
|
||||
[ ] [
|
||||
<dispatcher>
|
||||
add-quit-action
|
||||
"vocab:http/test/foo.html" <static> >>default
|
||||
test-httpd
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
"http://localhost/" add-port http-get nip
|
||||
"vocab:http/test/foo.html" ascii file-contents =
|
||||
] unit-test
|
||||
|
||||
[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test
|
||||
|
||||
! Check behavior of 307 redirect (reported by Chris Double)
|
||||
[ ] [
|
||||
<dispatcher>
|
||||
add-quit-action
|
||||
<action>
|
||||
[ "b" <temporary-redirect> ] >>submit
|
||||
"a" add-responder
|
||||
<action>
|
||||
[
|
||||
request get post-data>> data>> "data" =
|
||||
[ "OK" "text/plain" <content> ] [ "OOPS" throw ] if
|
||||
] >>submit
|
||||
"b" add-responder
|
||||
test-httpd
|
||||
] unit-test
|
||||
|
||||
[ "OK" ] [ "data" "http://localhost/a" add-port http-post nip ] unit-test
|
||||
|
||||
[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test
|
||||
|
|
@ -47,8 +47,8 @@ TUPLE: file-responder root hook special allow-listings ;
|
|||
if ;
|
||||
|
||||
: serving-path ( filename -- filename )
|
||||
[ file-responder get root>> trim-tail-separators "/" ] dip
|
||||
"" or trim-head-separators 3append ;
|
||||
[ file-responder get root>> trim-tail-separators ] dip
|
||||
[ "/" swap trim-head-separators 3append ] unless-empty ;
|
||||
|
||||
: serve-file ( filename -- response )
|
||||
dup mime-type
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ] }
|
||||
|
|
|
|||
|
|
@ -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 } }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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* ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||
! Copyright (C) 2006, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel namespaces opengl opengl.gl ;
|
||||
USING: kernel namespaces opengl opengl.gl fry ;
|
||||
IN: ui.backend
|
||||
|
||||
SYMBOL: ui-backend
|
||||
|
|
@ -28,7 +28,7 @@ GENERIC: flush-gl-context ( handle -- )
|
|||
HOOK: offscreen-pixels ui-backend ( world -- alien w h )
|
||||
|
||||
: with-gl-context ( handle quot -- )
|
||||
swap [ select-gl-context call ] keep
|
||||
flush-gl-context gl-error ; inline
|
||||
'[ select-gl-context @ ]
|
||||
[ flush-gl-context gl-error ] bi ; inline
|
||||
|
||||
HOOK: (with-ui) ui-backend ( quot -- )
|
||||
|
|
@ -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" }
|
||||
|
|
|
|||
|
|
@ -1,9 +1,10 @@
|
|||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs continuations kernel math models
|
||||
namespaces opengl sequences io combinators combinators.short-circuit
|
||||
fry math.vectors math.rectangles cache ui.gadgets ui.gestures
|
||||
ui.render ui.backend ui.gadgets.tracks ui.commands ;
|
||||
namespaces opengl opengl.capabilities opengl.textures sequences io
|
||||
combinators combinators.short-circuit fry math.vectors math.rectangles
|
||||
cache ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
|
||||
ui.commands ;
|
||||
IN: ui.gadgets.worlds
|
||||
|
||||
TUPLE: world < track
|
||||
|
|
@ -76,8 +77,13 @@ SYMBOL: flush-layout-cache-hook
|
|||
|
||||
flush-layout-cache-hook [ [ ] ] initialize
|
||||
|
||||
: check-extensions ( -- )
|
||||
"2.0" { "GL_ARB_texture_non_power_of_two" } has-gl-version-or-extensions?
|
||||
non-power-of-2-textures? set ;
|
||||
|
||||
: (draw-world) ( world -- )
|
||||
dup handle>> [
|
||||
check-extensions
|
||||
{
|
||||
[ init-gl ]
|
||||
[ draw-gadget ]
|
||||
|
|
|
|||
|
|
@ -2,9 +2,9 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs io kernel math models namespaces make dlists
|
||||
deques sequences threads sequences words continuations init
|
||||
combinators hashtables concurrency.flags sets accessors calendar fry
|
||||
destructors ui.gadgets ui.gadgets.private ui.gadgets.worlds
|
||||
ui.gadgets.tracks ui.gestures ui.backend ui.render ;
|
||||
combinators combinators.short-circuit hashtables concurrency.flags
|
||||
sets accessors calendar fry destructors ui.gadgets ui.gadgets.private
|
||||
ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render ;
|
||||
IN: ui
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -117,12 +117,10 @@ M: world ungraft*
|
|||
gesture-queue [ send-queued-gesture notify-queued ] slurp-deque ;
|
||||
|
||||
: update-ui ( -- )
|
||||
[
|
||||
notify-queued
|
||||
layout-queued
|
||||
redraw-worlds
|
||||
send-queued-gestures
|
||||
] [ ui-error ] recover ;
|
||||
send-queued-gestures ;
|
||||
|
||||
SYMBOL: ui-thread
|
||||
|
||||
|
|
@ -133,8 +131,7 @@ SYMBOL: ui-thread
|
|||
PRIVATE>
|
||||
|
||||
: find-window ( quot -- world )
|
||||
windows get values
|
||||
[ gadget-child swap call ] with find-last nip ; inline
|
||||
[ windows get values ] dip '[ gadget-child @ ] find-last nip ; inline
|
||||
|
||||
: ui-running? ( -- ? )
|
||||
\ ui-running get-global ;
|
||||
|
|
@ -142,9 +139,15 @@ PRIVATE>
|
|||
<PRIVATE
|
||||
|
||||
: update-ui-loop ( -- )
|
||||
[ ui-running? ui-thread get-global self eq? and ]
|
||||
[ ui-notify-flag get lower-flag update-ui ]
|
||||
while ;
|
||||
#! Note the logic: if update-ui fails, we open an error window
|
||||
#! and run one iteration of update-ui. If that also fails, well,
|
||||
#! the whole UI subsystem is broken so we exit out of the
|
||||
#! update-ui-loop.
|
||||
[ { [ ui-running? ] [ ui-thread get-global self eq? ] } 0&& ]
|
||||
[
|
||||
ui-notify-flag get lower-flag
|
||||
[ update-ui ] [ ui-error update-ui ] recover
|
||||
] while ;
|
||||
|
||||
: start-ui-thread ( -- )
|
||||
[ self ui-thread set-global update-ui-loop ]
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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 }
|
||||
}
|
||||
|
|
@ -1,20 +1,28 @@
|
|||
USING: help.syntax help.markup ;
|
||||
USING: help.syntax help.markup words ;
|
||||
IN: descriptive
|
||||
|
||||
HELP: DESCRIPTIVE:
|
||||
{ $syntax "DESCRIPTIVE: word ( inputs -- outputs ) definition ;" }
|
||||
{ $description "Defines a word such that, if an error is thrown from within it, that error is wrapped in a descriptive tag including the arguments to that word." } ;
|
||||
{ $description "Defines a word such that, if an error is thrown from within it, that error is wrapped in a " { $link descriptive-error } " with the arguments to that word." } ;
|
||||
|
||||
HELP: DESCRIPTIVE::
|
||||
{ $syntax "DESCRIPTIVE:: word ( inputs -- outputs ) definition ;" }
|
||||
{ $description "Defines a word which uses locals such that, if an error is thrown from within it, that error is wrapped in a descriptive tag including the arguments to that word." } ;
|
||||
{ $description "Defines a word which uses locals such that, if an error is thrown from within it, that error is wrapped in a " { $link descriptive-error } " with the arguments to that word." } ;
|
||||
|
||||
HELP: descriptive
|
||||
{ $class-description "The class of errors wrapping another error (in the underlying slot) which were thrown in a word (in the word slot) with a given set of arguments (in the args slot)." } ;
|
||||
HELP: descriptive-error
|
||||
{ $error-description "The class of errors wrapping another error (in the underlying slot) which were thrown in a word (in the word slot) with a given set of arguments (in the args slot)." } ;
|
||||
|
||||
HELP: make-descriptive
|
||||
{ $values { "word" word } }
|
||||
{ $description "Makes the word wrap errors in " { $link descriptive-error } " instances." } ;
|
||||
|
||||
ARTICLE: "descriptive" "Descriptive errors"
|
||||
"This vocabulary defines automatic descriptive errors. Using it, you can define a word which acts as normal, except when it throws an error, the error is wrapped in a special descriptor declaring that an error was thrown from inside that word, and including the arguments given to that word. The error is of the following class:"
|
||||
{ $subsection descriptive }
|
||||
"This vocabulary defines automatic descriptive errors. Using it, you can define a word which acts as normal, except when it throws an error, the error is wrapped in an instance of a class:"
|
||||
{ $subsection descriptive-error }
|
||||
"The wrapper contains the word itself, the input parameters, as well as the original error."
|
||||
$nl
|
||||
"To annotate an existing word with descriptive error checking:"
|
||||
{ $subsection make-descriptive }
|
||||
"To define words which throw descriptive errors, use the following words:"
|
||||
{ $subsection POSTPONE: DESCRIPTIVE: }
|
||||
{ $subsection POSTPONE: DESCRIPTIVE:: } ;
|
||||
|
|
|
|||
|
|
@ -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 ]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -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." } ;
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -4,8 +4,10 @@ USING: accessors ascii binary-search combinators kernel locals math
|
|||
math.bitwise math.order poker.arrays sequences splitting ;
|
||||
IN: poker
|
||||
|
||||
! The algorithm used is based on Cactus Kev's Poker Hand Evaluator:
|
||||
! The algorithm used is based on Cactus Kev's Poker Hand Evaluator with
|
||||
! the Senzee Perfect Hash Optimization:
|
||||
! http://www.suffecool.net/poker/evaluator.html
|
||||
! http://www.senzee5.com/2006/06/some-perfect-hash.html
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
|
@ -124,14 +126,22 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush"
|
|||
: prime-bits ( cards -- q )
|
||||
[ HEX: FF bitand ] map-product ;
|
||||
|
||||
: perfect-hash-find ( q -- value )
|
||||
#! magic to convert a hand's unique identifying bits to the
|
||||
#! proper index for fast lookup in a table of hand values
|
||||
HEX: E91AAA35 +
|
||||
dup -16 shift bitxor
|
||||
dup 8 shift w+
|
||||
dup -4 shift bitxor
|
||||
[ -8 shift HEX: 1FF bitand adjustments-table nth ]
|
||||
[ dup 2 shift w+ -19 shift ] bi
|
||||
bitxor values-table nth ;
|
||||
|
||||
: hand-value ( cards -- value )
|
||||
{
|
||||
{ [ dup flush? ] [ flushes-table lookup ] }
|
||||
{ [ dup unique5? ] [ unique5-table lookup ] }
|
||||
[
|
||||
prime-bits products-table sorted-index
|
||||
values-table nth
|
||||
]
|
||||
[ prime-bits perfect-hash-find ]
|
||||
} cond ;
|
||||
|
||||
: >card-rank ( card -- str )
|
||||
|
|
@ -145,6 +155,19 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush"
|
|||
[ drop "S" ]
|
||||
} cond ;
|
||||
|
||||
: hand-rank ( hand -- rank )
|
||||
value>> {
|
||||
{ [ dup 6185 > ] [ drop HIGH_CARD ] } ! 1277 high card
|
||||
{ [ dup 3325 > ] [ drop ONE_PAIR ] } ! 2860 one pair
|
||||
{ [ dup 2467 > ] [ drop TWO_PAIR ] } ! 858 two pair
|
||||
{ [ dup 1609 > ] [ drop THREE_OF_A_KIND ] } ! 858 three-kind
|
||||
{ [ dup 1599 > ] [ drop STRAIGHT ] } ! 10 straights
|
||||
{ [ dup 322 > ] [ drop FLUSH ] } ! 1277 flushes
|
||||
{ [ dup 166 > ] [ drop FULL_HOUSE ] } ! 156 full house
|
||||
{ [ dup 10 > ] [ drop FOUR_OF_A_KIND ] } ! 156 four-kind
|
||||
[ drop STRAIGHT_FLUSH ] ! 10 straight-flushes
|
||||
} cond ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
TUPLE: hand
|
||||
|
|
@ -159,23 +182,10 @@ M: hand equal?
|
|||
" " split [ >ckf ] map
|
||||
dup hand-value hand boa ;
|
||||
|
||||
: hand-rank ( hand -- rank )
|
||||
value>> {
|
||||
{ [ dup 6185 > ] [ drop HIGH_CARD ] } ! 1277 high card
|
||||
{ [ dup 3325 > ] [ drop ONE_PAIR ] } ! 2860 one pair
|
||||
{ [ dup 2467 > ] [ drop TWO_PAIR ] } ! 858 two pair
|
||||
{ [ dup 1609 > ] [ drop THREE_OF_A_KIND ] } ! 858 three-kind
|
||||
{ [ dup 1599 > ] [ drop STRAIGHT ] } ! 10 straights
|
||||
{ [ dup 322 > ] [ drop FLUSH ] } ! 1277 flushes
|
||||
{ [ dup 166 > ] [ drop FULL_HOUSE ] } ! 156 full house
|
||||
{ [ dup 10 > ] [ drop FOUR_OF_A_KIND ] } ! 156 four-kind
|
||||
[ drop STRAIGHT_FLUSH ] ! 10 straight-flushes
|
||||
} cond ;
|
||||
|
||||
: >value ( hand -- str )
|
||||
hand-rank VALUE_STR nth ;
|
||||
|
||||
: >cards ( hand -- str )
|
||||
cards>> [
|
||||
[ >card-rank ] [ >card-suit ] bi append
|
||||
] map " " join ;
|
||||
|
||||
: >value ( hand -- str )
|
||||
hand-rank VALUE_STR nth ;
|
||||
|
|
|
|||
|
|
@ -17,9 +17,6 @@ IN: project-euler.007
|
|||
! SOLUTION
|
||||
! --------
|
||||
|
||||
: nth-prime ( n -- n )
|
||||
1- lprimes lnth ;
|
||||
|
||||
: euler007 ( -- answer )
|
||||
10001 nth-prime ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -0,0 +1,3 @@
|
|||
USING: project-euler.058 tools.test ;
|
||||
|
||||
{ 26241 } [ euler058 ] unit-test
|
||||
|
|
@ -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
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
USING: project-euler.063 tools.test ;
|
||||
|
||||
{ 49 } [ euler063 ] unit-test
|
||||
|
|
@ -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
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USING: project-euler.069 tools.test ;
|
||||
|
||||
{ 510510 } [ euler069 ] unit-test
|
||||
{ 510510 } [ euler069a ] unit-test
|
||||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -1,9 +1,10 @@
|
|||
! Copyright (c) 2007-2008 Aaron Schaefer.
|
||||
! Copyright (c) 2007-2009 Aaron Schaefer.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel make math math.functions math.matrices math.miller-rabin
|
||||
math.order math.parser math.primes.factors math.ranges math.ratios
|
||||
sequences sorting strings unicode.case parser accessors vocabs.parser
|
||||
namespaces vocabs words quotations prettyprint ;
|
||||
USING: accessors arrays kernel lists make math math.functions math.matrices
|
||||
math.miller-rabin math.order math.parser math.primes.factors
|
||||
math.primes.lists math.ranges math.ratios namespaces parser prettyprint
|
||||
quotations sequences sorting strings unicode.case vocabs vocabs.parser
|
||||
words ;
|
||||
IN: project-euler.common
|
||||
|
||||
! A collection of words used by more than one Project Euler solution
|
||||
|
|
@ -16,11 +17,13 @@ IN: project-euler.common
|
|||
! log10 - #25, #134
|
||||
! max-path - #18, #67
|
||||
! mediant - #71, #73
|
||||
! nth-prime - #7, #69
|
||||
! nth-triangle - #12, #42
|
||||
! number>digits - #16, #20, #30, #34, #35, #38, #43, #52, #55, #56, #92
|
||||
! palindrome? - #4, #36, #55
|
||||
! pandigital? - #32, #38
|
||||
! pentagonal? - #44, #45
|
||||
! penultimate - #69, #71
|
||||
! propagate-all - #18, #67
|
||||
! sum-proper-divisors - #21
|
||||
! tau* - #12
|
||||
|
|
@ -78,6 +81,9 @@ PRIVATE>
|
|||
: number-length ( n -- m )
|
||||
log10 floor 1+ >integer ;
|
||||
|
||||
: nth-prime ( n -- n )
|
||||
1- lprimes lnth ;
|
||||
|
||||
: nth-triangle ( n -- n )
|
||||
dup 1+ * 2 / ;
|
||||
|
||||
|
|
@ -90,6 +96,9 @@ PRIVATE>
|
|||
: pentagonal? ( n -- ? )
|
||||
dup 0 > [ 24 * 1+ sqrt 1+ 6 / 1 mod zero? ] [ drop f ] if ;
|
||||
|
||||
: penultimate ( seq -- elt )
|
||||
dup length 2 - swap nth ;
|
||||
|
||||
! Not strictly needed, but it is nice to be able to dump the triangle after the
|
||||
! propagation
|
||||
: propagate-all ( triangle -- new-triangle )
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (c) 2007, 2008, 2009 Aaron Schaefer, Samuel Tardieu.
|
||||
! Copyright (c) 2007-2009 Aaron Schaefer, Samuel Tardieu.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: definitions io io.files io.pathnames kernel math math.parser
|
||||
prettyprint project-euler.ave-time sequences vocabs vocabs.loader
|
||||
|
|
@ -15,13 +15,14 @@ USING: definitions io io.files io.pathnames kernel math math.parser
|
|||
project-euler.041 project-euler.042 project-euler.043 project-euler.044
|
||||
project-euler.045 project-euler.046 project-euler.047 project-euler.048
|
||||
project-euler.049 project-euler.052 project-euler.053 project-euler.054
|
||||
project-euler.055 project-euler.056 project-euler.057 project-euler.059
|
||||
project-euler.067 project-euler.071 project-euler.073 project-euler.075
|
||||
project-euler.076 project-euler.079 project-euler.092 project-euler.097
|
||||
project-euler.099 project-euler.100 project-euler.116 project-euler.117
|
||||
project-euler.134 project-euler.148 project-euler.150 project-euler.151
|
||||
project-euler.164 project-euler.169 project-euler.173 project-euler.175
|
||||
project-euler.186 project-euler.190 project-euler.203 project-euler.215 ;
|
||||
project-euler.055 project-euler.056 project-euler.057 project-euler.058
|
||||
project-euler.059 project-euler.063 project-euler.067 project-euler.069
|
||||
project-euler.071 project-euler.073 project-euler.075 project-euler.076
|
||||
project-euler.079 project-euler.092 project-euler.097 project-euler.099
|
||||
project-euler.100 project-euler.116 project-euler.117 project-euler.134
|
||||
project-euler.148 project-euler.150 project-euler.151 project-euler.164
|
||||
project-euler.169 project-euler.173 project-euler.175 project-euler.186
|
||||
project-euler.190 project-euler.203 project-euler.215 ;
|
||||
IN: project-euler
|
||||
|
||||
<PRIVATE
|
||||
|
|
|
|||
|
|
@ -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/"
|
||||
"/scripts/"
|
||||
"/ChipList2/scripts/"
|
||||
"/ChipList2/styles/"
|
||||
"/ads/"
|
||||
"/ChipList2/ads/"
|
||||
"/advertisements/"
|
||||
"/ChipList2/advertisements/"
|
||||
"/graphics/"
|
||||
"/ChipList2/graphics/"
|
||||
URL" /cgi-bin/"
|
||||
URL" /scripts/"
|
||||
URL" /ChipList2/scripts/"
|
||||
URL" /ChipList2/styles/"
|
||||
URL" /ads/"
|
||||
URL" /ChipList2/ads/"
|
||||
URL" /advertisements/"
|
||||
URL" /ChipList2/advertisements/"
|
||||
URL" /graphics/"
|
||||
URL" /ChipList2/graphics/"
|
||||
}
|
||||
}
|
||||
{ visit-time
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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-disallow ( rules disallow -- rules ) over disallows>> push ;
|
||||
: add-allow ( rules allow -- rules ) >url over allows>> 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 )
|
||||
get-robots.txt nip parse-robots.txt ;
|
||||
: robots ( url -- robots )
|
||||
>url
|
||||
dup get-robots.txt nip parse-robots.txt <robots> ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
smtp ;
|
||||
namespaces sequences site-watcher.db site-watcher.email ;
|
||||
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 ]
|
||||
} cleave send-email ;
|
||||
[ [ url>> ] [ up?>> "up" "down" ? ] bi " is " glue ] tri
|
||||
send-site-email ;
|
||||
|
||||
: send-reports ( seq -- )
|
||||
[ ] [ [ send-report ] each ] if-empty ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: watch-sites ( db -- )
|
||||
[ find-sites check-sites sites-to-report send-reports ] with-db ;
|
||||
: watch-sites ( -- )
|
||||
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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
f url spider spidered>> set-at
|
||||
[ url http-get ] benchmark :> fetched-at :> html :> headers
|
||||
:: fill-spidered-result ( spider spider-result -- )
|
||||
f spider-result url>> spider spidered>> set-at
|
||||
[ 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
|
||||
url depth headers fetched-at parsed-html links processing-time
|
||||
now spider-result boa ;
|
||||
] benchmark :> processed-in :> links :> parsed-html
|
||||
spider-result
|
||||
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 quiet>> [ url depth print-spidering ] unless
|
||||
spider url depth new-spidered-result :> spidered-result
|
||||
spider quiet>> [ spidered-result describe ] unless
|
||||
spider spidered-result add-spidered ;
|
||||
:: spider-page ( spider spider-result -- )
|
||||
spider quiet>> [ spider-result print-spidering ] unless
|
||||
spider spider-result fill-spidered-result
|
||||
spider quiet>> [ spider-result describe ] unless
|
||||
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 ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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>
|
||||
|
|
@ -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>
|
||||
|
|
@ -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>
|
||||
|
|
@ -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>
|
||||
|
|
@ -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>
|
||||
|
|
@ -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>
|
||||
[
|
||||
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 ;
|
||||
{ site-watcher-app "main" } >>template ;
|
||||
|
||||
: <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
|
||||
<add-site-action> "add" add-responder
|
||||
<remove-site-action> "remove" add-responder
|
||||
<watch-list-action> "watch-list" add-responder
|
||||
<add-watched-site-action> "add-watch" 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 ( -- )
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -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 ;
|
||||
Loading…
Reference in New Issue