[ t ] [
symbolic-stack-trace
[ word? ] filter
- { baz bar foo throw } tail?
+ { baz bar foo } tail?
] unit-test
: bleh ( seq -- seq' ) [ 3 + ] map [ 0 > ] filter ;
"placed on the top of the stack."\r
}\r
{ $examples\r
- { $example "USING: kernel prettyprint generalizations ;" "1 2 3 4 4 npick .s clear" "1\n2\n3\n4\n1" }\r
+ { $example "USING: kernel prettyprint generalizations ;" "1 2 3 4 4 npick 5 narray ." "{ 1 2 3 4 1 }" }\r
"Some core words expressed in terms of " { $link npick } ":"\r
{ $table\r
{ { $link dup } { $snippet "1 npick" } }\r
"placed on the top of the stack."\r
}\r
{ $examples\r
- { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 ndup .s clear" "1\n2\n3\n4\n1\n2\n3\n4" }\r
+ { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 ndup 8 narray ." "{ 1 2 3 4 1 2 3 4 }" }\r
"Some core words expressed in terms of " { $link ndup } ":"\r
{ $table\r
{ { $link dup } { $snippet "1 ndup" } }\r
"for any number of items."\r
}\r
{ $examples\r
- { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 nnip .s clear" "4" }\r
+ { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 nnip ." "4" }\r
"Some core words expressed in terms of " { $link nnip } ":"\r
{ $table\r
{ { $link nip } { $snippet "1 nnip" } }\r
"for any number of items."\r
}\r
{ $examples\r
- { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 ndrop .s clear" "1" }\r
+ { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 ndrop ." "1" }\r
"Some core words expressed in terms of " { $link ndrop } ":"\r
{ $table\r
{ { $link drop } { $snippet "1 ndrop" } }\r
"number of items on the stack. "\r
}\r
{ $examples\r
- { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 nrot .s clear" "2\n3\n4\n1" }\r
+ { $example "USING: arrays generalizations kernel prettyprint ;" "1 2 3 4 4 nrot 4array ." "{ 2 3 4 1 }" }\r
"Some core words expressed in terms of " { $link nrot } ":"\r
{ $table\r
{ { $link swap } { $snippet "1 nrot" } }\r
"number of items on the stack. "\r
}\r
{ $examples\r
- { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 -nrot .s clear" "4\n1\n2\n3" }\r
+ { $example "USING: arrays generalizations kernel prettyprint ;" "1 2 3 4 4 -nrot 4array ." "{ 4 1 2 3 }" }\r
"Some core words expressed in terms of " { $link -nrot } ":"\r
{ $table\r
{ { $link swap } { $snippet "1 -nrot" } }\r
"stack. The quotation can consume and produce any number of items."\r
} \r
{ $examples\r
- { $example "USING: generalizations kernel prettyprint kernel ;" "1 2 [ dup ] 1 ndip .s clear" "1\n1\n2" }\r
- { $example "USING: generalizations kernel prettyprint kernel ;" "1 2 3 [ drop ] 2 ndip .s clear" "2\n3" }\r
+ { $example "USING: arrays generalizations kernel prettyprint ;" "1 2 [ dup ] 1 ndip 3array ." "{ 1 1 2 }" }\r
+ { $example "USING: arrays generalizations kernel prettyprint ;" "1 2 3 [ drop ] 2 ndip 2array ." "{ 2 3 }" }\r
"Some core words expressed in terms of " { $link ndip } ":"\r
{ $table\r
{ { $link dip } { $snippet "1 ndip" } }\r
"removed from the stack, the quotation called, and the items restored."\r
} \r
{ $examples\r
- { $example "USING: generalizations kernel prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip .s clear" "99\n1\n2\n3\n4\n5" }\r
+ { $example "USING: generalizations kernel prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip 6 narray ." "{ 99 1 2 3 4 5 }" }\r
"Some core words expressed in terms of " { $link nslip } ":"\r
{ $table\r
{ { $link slip } { $snippet "1 nslip" } }\r
"saved, the quotation called, and the items restored."\r
} \r
{ $examples\r
- { $example "USING: generalizations kernel prettyprint ;" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep .s clear" "99\n1\n2\n3\n4\n5" }\r
+ { $example "USING: generalizations kernel prettyprint ;" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep 6 narray ." "{ 99 1 2 3 4 5 }" }\r
"Some core words expressed in terms of " { $link nkeep } ":"\r
{ $table\r
{ { $link keep } { $snippet "1 nkeep" } }\r
[ H{ } [ ] with-nesting nl ] make-html-string
] unit-test
-[ ] [ [ { 1 2 3 } describe ] with-html-writer drop ] unit-test
-
-[ ] [ [ \ predicate-instance? def>> . ] with-html-writer drop ] unit-test
+[ ] [ [ { 1 2 3 } describe ] with-html-writer drop ] unit-test
\ No newline at end of file
quotations arrays byte-arrays math.parser calendar
calendar.format present urls fry
io io.encodings io.encodings.iana io.encodings.binary
-io.encodings.8-bit io.crlf
-unicode.case unicode.categories
+io.encodings.8-bit io.crlf ascii
http.parsers
base64 ;
IN: http
: parse-content-type-attributes ( string -- attributes )
" " split harvest [
"=" split1
- [ >lower ] [ "\"" ?head drop "\"" ?tail drop ] bi*
+ "\"" ?head drop "\"" ?tail drop
] { } map>assoc ;
: parse-content-type ( content-type -- type encoding )
";" split1
- parse-content-type-attributes "charset" swap at
- [ name>encoding ]
- [ dup "text/" head? latin1 binary ? ] if* ;
+ parse-content-type-attributes "charset" swap at name>encoding
+ [ dup "text/" head? latin1 binary ? ] unless* ;
{ $subsection name>encoding }
{ $subsection encoding>name }
"To let a new encoding be used with the above words, use the following:"
-{ $subsection register-encoding }
-"Exceptions when encodings or names are not found:"
-{ $subsection missing-encoding }
-{ $subsection missing-name } ;
-
-HELP: missing-encoding
-{ $error-description "The error called from " { $link name>encoding } " when there is no encoding descriptor registered corresponding to the given name." } ;
-
-HELP: missing-name
-{ $error-description "The error called from " { $link encoding>name } " when there is no name registered corresponding to the given encoding." } ;
+{ $subsection register-encoding } ;
HELP: name>encoding
{ $values { "name" "an encoding name" } { "encoding" "an encoding descriptor" } }
-{ $description "Given an IANA-registered encoding name, find the encoding descriptor that represents it, or " { $code f } " if it is not found (either not implemented in Factor or not registered)." } ;
+{ $description "Given an IANA-registered encoding name, find the encoding descriptor that represents it, or " { $snippet "f" } " if it is not found (either not implemented in Factor or not registered)." } ;
HELP: encoding>name
{ $values { "encoding" "an encoding descriptor" } { "name" "an encoding name" } }
-{ $description "Given an encoding descriptor, return the preferred IANA name." } ;
+{ $description "Given an encoding descriptor, return the preferred IANA name. If no name is found, returns " { $snippet "f" } "." } ;
{ name>encoding encoding>name } related-words
"csEBCDICFISEA" n>e-table get delete-at
ebcdic-fisea e>n-table get delete-at
] unit-test
-[ "EBCDIC-FI-SE-A" name>encoding ] must-fail
-[ "csEBCDICFISEA" name>encoding ] must-fail
-[ ebcdic-fisea encoding>name ] must-fail
+[ f ] [ "EBCDIC-FI-SE-A" name>encoding ] unit-test
+[ f ] [ "csEBCDICFISEA" name>encoding ] unit-test
+[ f ] [ ebcdic-fisea encoding>name ] unit-test
[ ebcdic-fisea "foobar" register-encoding ] must-fail
-[ "foobar" name>encoding ] must-fail
-[ ebcdic-fisea encoding>name ] must-fail
+[ f ] [ "foobar" name>encoding ] unit-test
+[ f ] [ ebcdic-fisea encoding>name ] unit-test
SYMBOL: aliases
PRIVATE>
-ERROR: missing-encoding name ;
+: name>encoding ( name -- encoding/f )
+ n>e-table get-global at ;
-: name>encoding ( name -- encoding )
- dup n>e-table get-global at [ ] [ missing-encoding ] ?if ;
-
-ERROR: missing-name encoding ;
-
-: encoding>name ( encoding -- name )
- dup e>n-table get-global at [ ] [ missing-name ] ?if ;
+: encoding>name ( encoding -- name/f )
+ e>n-table get-global at ;
<PRIVATE
: parse-iana ( file -- synonym-set )
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors io.sockets.secure kernel ;
IN: io.sockets.secure.unix.debug
-: with-test-context ( quot -- )
+: <test-secure-config> ( -- config )
<secure-config>
"vocab:openssl/test/server.pem" >>key-file
"vocab:openssl/test/dh1024.pem" >>dh-file
- "password" >>password
+ "password" >>password ;
+
+: with-test-context ( quot -- )
+ <test-secure-config>
swap with-secure-context ; inline
! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays accessors fry sequences regexp.classes ;
-FROM: math.ranges => [a,b] ;
+USING: kernel arrays accessors fry sequences regexp.classes
+math.ranges math ;
IN: regexp.ast
TUPLE: negation term ;
<array> <concatenation> ;
GENERIC: <times> ( term times -- term' )
+
M: at-least <times>
n>> swap [ repetition ] [ <star> ] bi 2array <concatenation> ;
+
+: to-times ( term n -- ast )
+ dup zero?
+ [ 2drop epsilon ]
+ [ dupd 1- to-times 2array <concatenation> <maybe> ]
+ if ;
+
M: from-to <times>
- [ n>> ] [ m>> ] bi [a,b] swap '[ _ repetition ] map <alternation> ;
+ [ n>> swap repetition ]
+ [ [ m>> ] [ n>> ] bi - to-times ] 2bi
+ 2array <concatenation> ;
: char-class ( ranges ? -- term )
[ <or-class> ] dip [ <not-class> ] when ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math math.order words combinators locals
ascii unicode.categories combinators.short-circuit sequences
-fry macros arrays assocs sets classes mirrors ;
+fry macros arrays assocs sets classes mirrors unicode.script
+unicode.data ;
IN: regexp.classes
-SINGLETONS: any-char any-char-no-nl
-letter-class LETTER-class Letter-class digit-class
+SINGLETONS: dot letter-class LETTER-class Letter-class digit-class
alpha-class non-newline-blank-class
ascii-class punctuation-class java-printable-class blank-class
control-character-class hex-digit-class java-blank-class c-identifier-class
unmatchable-class terminator-class word-boundary-class ;
-SINGLETONS: beginning-of-input ^ end-of-input $ end-of-file ^unix $unix word-break ;
+SINGLETONS: beginning-of-input ^ end-of-input $ end-of-file
+^unix $unix word-break ;
-TUPLE: range from to ;
-C: <range> range
+TUPLE: range-class from to ;
+C: <range-class> range-class
+
+TUPLE: primitive-class class ;
+C: <primitive-class> primitive-class
+
+TUPLE: category-class category ;
+C: <category-class> category-class
+
+TUPLE: category-range-class category ;
+C: <category-range-class> category-range-class
+
+TUPLE: script-class script ;
+C: <script-class> script-class
GENERIC: class-member? ( obj class -- ? )
M: integer class-member? ( obj class -- ? ) = ;
-M: range class-member? ( obj class -- ? )
+M: range-class class-member? ( obj class -- ? )
[ from>> ] [ to>> ] bi between? ;
-M: any-char class-member? ( obj class -- ? )
- 2drop t ;
-
-M: any-char-no-nl class-member? ( obj class -- ? )
- drop CHAR: \n = not ;
-
M: letter-class class-member? ( obj class -- ? )
drop letter? ;
M: terminator-class class-member? ( obj class -- ? )
drop "\r\n\u000085\u002029\u002028" member? ;
-M: ^ class-member? ( obj class -- ? )
- 2drop f ;
+M: f class-member? 2drop f ;
-M: $ class-member? ( obj class -- ? )
- 2drop f ;
+M: script-class class-member?
+ [ script-of ] [ script>> ] bi* = ;
-M: f class-member? 2drop f ;
+M: category-class class-member?
+ [ category# ] [ category>> ] bi* = ;
-TUPLE: primitive-class class ;
-C: <primitive-class> primitive-class
+M: category-range-class class-member?
+ [ category first ] [ category>> ] bi* = ;
TUPLE: not-class class ;
PREDICATE: not-integer < not-class class>> integer? ;
-PREDICATE: not-primitive < not-class class>> primitive-class? ;
+
+UNION: simple-class
+ primitive-class range-class category-class category-range-class dot ;
+PREDICATE: not-simple < not-class class>> simple-class? ;
M: not-class class-member?
class>> class-member? not ;
[ drop class new seq { } like >>seq ]
} case ; inline
-TUPLE: class-partition integers not-integers primitives not-primitives and or other ;
+TUPLE: class-partition integers not-integers simples not-simples and or other ;
: partition-classes ( seq -- class-partition )
prune
[ integer? ] partition
[ not-integer? ] partition
- [ primitive-class? ] partition ! extend primitive-class to epsilon tags
- [ not-primitive? ] partition
+ [ simple-class? ] partition
+ [ not-simple? ] partition
[ and-class? ] partition
[ or-class? ] partition
class-partition boa ;
: filter-not-integers ( partition -- partition' )
dup
- [ primitives>> ] [ not-primitives>> ] [ or>> ] tri
+ [ simples>> ] [ not-simples>> ] [ or>> ] tri
3append and-class boa
'[ [ class>> _ class-member? ] filter ] change-not-integers ;
: answer-ors ( partition -- partition' )
- dup [ not-integers>> ] [ not-primitives>> ] [ primitives>> ] tri 3append
+ dup [ not-integers>> ] [ not-simples>> ] [ simples>> ] tri 3append
'[ [ _ [ t substitute ] each ] map ] change-or ;
: contradiction? ( partition -- ? )
{
- [ [ primitives>> ] [ not-primitives>> ] bi intersects? ]
+ [ [ simples>> ] [ not-simples>> ] bi intersects? ]
[ other>> f swap member? ]
} 1|| ;
: filter-integers ( partition -- partition' )
dup
- [ primitives>> ] [ not-primitives>> ] [ and>> ] tri
+ [ simples>> ] [ not-simples>> ] [ and>> ] tri
3append or-class boa
'[ [ _ class-member? not ] filter ] change-integers ;
: answer-ands ( partition -- partition' )
- dup [ integers>> ] [ not-primitives>> ] [ primitives>> ] tri 3append
+ dup [ integers>> ] [ not-simples>> ] [ simples>> ] tri 3append
'[ [ _ [ f substitute ] each ] map ] change-and ;
: tautology? ( partition -- ? )
{
- [ [ primitives>> ] [ not-primitives>> ] bi intersects? ]
+ [ [ simples>> ] [ not-simples>> ] bi intersects? ]
[ other>> t swap member? ]
} 1|| ;
M: primitive-class class-member?
class>> class-member? ;
-UNION: class primitive-class not-class or-class and-class range ;
-
TUPLE: condition question yes no ;
C: <condition> condition
PRIVATE>
-CONSTANT: <nothing> R/ (?~.*)/
+CONSTANT: <nothing> R/ (?~.*)/s
: <literal> ( string -- regexp )
[ "\\Q" "\\E" surround ] [ <concatenation> ] bi make-regexp ; foldable
: <char-range> ( char1 char2 -- regexp )
[ [ "[" "-" surround ] [ "]" append ] bi* append ]
- [ <range> ]
+ [ <range-class> ]
2bi make-regexp ;
: <or> ( regexps -- disjunction )
USING: accessors arrays assocs grouping kernel locals math namespaces
sequences fry quotations math.order math.ranges vectors
unicode.categories regexp.transition-tables words sets hashtables
-combinators.short-circuit unicode.case unicode.case.private regexp.ast
-regexp.classes ;
+combinators.short-circuit unicode.data regexp.ast
+regexp.classes memoize ;
IN: regexp.nfa
-! This uses unicode.case.private for ch>upper and ch>lower
+! This uses unicode.data for ch>upper and ch>lower
! but case-insensitive matching should be done by case-folding everything
! before processing starts
M: not-class modify-class
class>> modify-class <not-class> ;
-M: any-char modify-class
- drop dotall option? t any-char-no-nl ? ;
+MEMO: unix-dot ( -- class )
+ CHAR: \n <not-class> ;
+
+MEMO: nonl-dot ( -- class )
+ { CHAR: \n CHAR: \r } <or-class> <not-class> ;
+
+M: dot modify-class
+ drop dotall option? [ t ] [
+ unix-lines option?
+ unix-dot nonl-dot ?
+ ] if ;
: modify-letter-class ( class -- newclass )
case-insensitive option? [ drop Letter-class ] when ;
[ [ LETTER? ] bi@ and ]
} 2|| ;
-M: range modify-class
+M: range-class modify-class
case-insensitive option? [
dup cased-range? [
[ from>> ] [ to>> ] bi
- [ [ ch>lower ] bi@ <range> ]
- [ [ ch>upper ] bi@ <range> ] 2bi
+ [ [ ch>lower ] bi@ <range-class> ]
+ [ [ ch>upper ] bi@ <range-class> ] 2bi
2array <or-class>
] when
] when ;
-M: class nfa-node
+M: object nfa-node
modify-class add-simple-entry ;
M: with-options nfa-node ( node -- start end )
ERROR: bad-class name ;
+: parse-unicode-class ( name -- class )
+ ! Implement this!
+ drop f ;
+
+: unicode-class ( name -- class )
+ dup parse-unicode-class [ ] [ bad-class ] ?if ;
+
: name>class ( name -- class )
>string >case-fold {
{ "lower" letter-class }
{ "cntrl" control-character-class }
{ "xdigit" hex-digit-class }
{ "space" java-blank-class }
- ! TODO: unicode-character-class
- } [ bad-class ] at-error ;
+ } [ unicode-class ] at-error ;
: lookup-escape ( char -- ast )
{
RangeCharacter = !("]") AnyRangeCharacter
-Range = RangeCharacter:a "-" RangeCharacter:b => [[ a b <range> ]]
+Range = RangeCharacter:a "-" RangeCharacter:b => [[ a b <range-class> ]]
| RangeCharacter
-StartRange = AnyRangeCharacter:a "-" RangeCharacter:b => [[ a b <range> ]]
+StartRange = AnyRangeCharacter:a "-" RangeCharacter:b => [[ a b <range-class> ]]
| AnyRangeCharacter
Ranges = StartRange:s Range*:r => [[ r s prefix ]]
Element = "(" Parenthized:p ")" => [[ p ]]
| "[" CharClass:r "]" => [[ r ]]
- | ".":d => [[ any-char <primitive-class> ]]
+ | ".":d => [[ dot ]]
| Character
Number = (!(","|"}").)* => [[ string>number ensure-number ]]
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel make prettyprint.backend
+prettyprint.custom regexp regexp.parser regexp.private ;
+IN: regexp.prettyprint
+
+M: regexp pprint*
+ [
+ [
+ [ raw>> dup find-regexp-syntax swap % swap % % ]
+ [ options>> options>string % ] bi
+ ] "" make
+ ] keep present-text ;
\ No newline at end of file
! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators kernel kernel.private math sequences
-sequences.private strings sets assocs prettyprint.backend
-prettyprint.custom make lexer namespaces parser arrays fry locals
-regexp.parser splitting sorting regexp.ast regexp.negation
-regexp.compiler compiler.units words math.ranges ;
+sequences.private strings sets assocs make lexer namespaces parser
+arrays fry locals regexp.parser splitting sorting regexp.ast
+regexp.negation regexp.compiler compiler.units words math.ranges ;
IN: regexp
TUPLE: regexp
: R{ CHAR: } parsing-regexp ; parsing
: R| CHAR: | parsing-regexp ; parsing
-M: regexp pprint*
- [
- [
- [ raw>> dup find-regexp-syntax swap % swap % % ]
- [ options>> options>string % ] bi
- ] "" make
- ] keep present-text ;
+USING: vocabs vocabs.loader ;
+"prettyprint" vocab [
+ "regexp.prettyprint" require
+] when
\ No newline at end of file
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: sequences splitting kernel math.parser io.files io.encodings.ascii biassocs ;
+USING: sequences splitting kernel math.parser io.files io.encodings.utf8
+biassocs ascii ;
IN: simple-flat-file
: drop-comments ( seq -- newseq )
- [ "#" split1 drop ] map harvest ;
+ [ "#@" split first ] map harvest ;
: split-column ( line -- columns )
" \t" split harvest 2 short head 2 f pad-tail ;
drop-comments [ parse-line ] map ;
: flat-file>biassoc ( filename -- biassoc )
- ascii file-lines process-codetable-lines >biassoc ;
+ utf8 file-lines process-codetable-lines >biassoc ;
+: split-; ( line -- array )
+ ";" split [ [ blank? ] trim ] map ;
+
+: data ( filename -- data )
+ utf8 file-lines drop-comments [ split-; ] map ;
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel generic sequences io words arrays summary effects
-assocs accessors namespaces compiler.errors stack-checker.values
-stack-checker.recursive-state ;
+continuations assocs accessors namespaces compiler.errors
+stack-checker.values stack-checker.recursive-state ;
IN: stack-checker.errors
: pretty-word ( word -- word' )
: (inference-error) ( ... class type -- * )
[ boa ] dip
recursive-state get word>>
- \ inference-error boa throw ; inline
+ \ inference-error boa rethrow ; inline
: inference-error ( ... class -- * )
+error+ (inference-error) ; inline
[ t ] [ "webkit-demo" shake-and-bake 500000 small-enough? ] unit-test\r
] when\r
\r
+[ t ] [ "benchmark.regex-dna" shake-and-bake 900000 small-enough? ] unit-test\r
+\r
{\r
"tools.deploy.test.1"\r
"tools.deploy.test.2"\r
] when ;
: strip-call ( -- )
- "call" vocab [
- "Stripping stack effect checking from call( and execute(" show
- "vocab:tools/deploy/shaker/strip-call.factor"
- run-file
- ] when ;
+ "Stripping stack effect checking from call( and execute(" show
+ "vocab:tools/deploy/shaker/strip-call.factor" run-file ;
: strip-cocoa ( -- )
"cocoa" vocab [
! See http://factorcode.org/license.txt for BSD license.
IN: tools.deploy.shaker.call
-IN: call
-USE: call.private
+IN: combinators
+USE: combinators.private
: call-effect ( word effect -- ) call-effect-unsafe ; inline
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.short-circuit unicode.categories kernel math
combinators splitting sequences math.parser io.files io assocs
-arrays namespaces make math.ranges unicode.normalize.private values
-io.encodings.ascii unicode.syntax unicode.data compiler.units fry
+arrays namespaces make math.ranges unicode.normalize
+unicode.normalize.private values io.encodings.ascii
+unicode.syntax unicode.data compiler.units fry
alien.syntax sets accessors interval-maps memoize locals words ;
IN: unicode.breaks
VALUE: word-break-table
-"vocab:unicode/data/WordBreakProperty.txt" load-script
+"vocab:unicode/data/WordBreakProperty.txt" load-key-value
to: word-break-table
C-ENUM: wOther wCR wLF wNewline wExtend wFormat wKatakana wALetter wMidLetter
! Copyright (C) 2008, 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: unicode.case unicode.case.private tools.test namespaces strings unicode.normalize ;
+USING: unicode.case tools.test namespaces strings unicode.normalize
+unicode.case.private ;
IN: unicode.case.tests
\ >upper must-infer
QUALIFIED: ascii
IN: unicode.case
-<PRIVATE
-: ch>lower ( ch -- lower ) simple-lower at-default ; inline
-: ch>upper ( ch -- upper ) simple-upper at-default ; inline
-: ch>title ( ch -- title ) simple-title at-default ; inline
-PRIVATE>
-
SYMBOL: locale ! Just casing locale, or overall?
<PRIVATE
:: map-case ( string string-quot char-quot -- case )
string length <sbuf> :> out
string [
- dup special-casing at
+ dup special-case
[ string-quot call out push-all ]
[ char-quot call out push ] ?if
] each out "" like ; inline
-USING: tools.test kernel unicode.categories words sequences unicode.syntax ;
+! Copyright (C) 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test kernel unicode.categories words sequences unicode.data ;
+IN: unicode.categories.tests
[ { f f t t f t t f f t } ] [ CHAR: A {
blank? letter? LETTER? Letter? digit?
ascii io assocs strings math namespaces make sorting combinators\r
math.order arrays unicode.normalize unicode.data locals\r
unicode.syntax macros sequences.deep words unicode.breaks\r
-quotations combinators.short-circuit ;\r
+quotations combinators.short-circuit simple-flat-file ;\r
IN: unicode.collation\r
\r
<PRIVATE\r
[ >>primary ] [ >>secondary ] [ >>tertiary ] tri*\r
] map ;\r
\r
-: parse-line ( line -- code-poing weight )\r
- ";" split1 [ [ blank? ] trim ] bi@\r
- [ " " split [ hex> ] "" map-as ] [ parse-weight ] bi* ;\r
+: parse-keys ( string -- chars )\r
+ " " split [ hex> ] "" map-as ;\r
\r
: parse-ducet ( file -- ducet )\r
- ascii file-lines filter-comments\r
- [ parse-line ] H{ } map>assoc ;\r
+ data [ [ parse-keys ] [ parse-weight ] bi* ] H{ } assoc-map-as ;\r
\r
"vocab:unicode/collation/allkeys.txt" parse-ducet to: ducet\r
\r
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
USING: help.syntax help.markup strings ;
IN: unicode.data
ARTICLE: "unicode.data" "Unicode data tables"
"The " { $vocab-link "unicode.data" "unicode.data" } " vocabulary contains core Unicode data tables and code for parsing this from files."
-{ $subsection load-script }
{ $subsection canonical-entry }
{ $subsection combine-chars }
{ $subsection combining-class }
{ $subsection non-starter? }
{ $subsection name>char }
{ $subsection char>name }
-{ $subsection property? } ;
-
-HELP: load-script
-{ $values { "filename" string } { "table" "an interval map" } }
-{ $description "This loads a file that looks like Script.txt in the Unicode Character Database and converts it into an efficient interval map, where the keys are characters and the values are strings for the properties." } ;
+{ $subsection property? }
+{ $subsection load-key-value } ;
HELP: canonical-entry
{ $values { "char" "a code point" } { "seq" string } }
HELP: property?
{ $values { "char" "a code point" } { "property" string } { "?" "a boolean" } }
{ $description "Tests whether the code point is listed under the given property in PropList.txt in the Unicode Character Database." } ;
+
+HELP: load-key-value
+{ $values { "filename" string } { "table" "an interval map" } }
+{ $description "This loads a file that looks like Script.txt in the Unicode Character Database and converts it into an efficient interval map, where the keys are characters and the values are strings for the properties." } ;
-! Copyright (C) 2008 Daniel Ehrenberg.
+! Copyright (C) 2008, 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.short-circuit assocs math kernel sequences
io.files hashtables quotations splitting grouping arrays io
math.parser hash2 math.order byte-arrays words namespaces words
compiler.units parser io.encodings.ascii values interval-maps
ascii sets combinators locals math.ranges sorting make
-strings.parser io.encodings.utf8 memoize ;
+strings.parser io.encodings.utf8 memoize simple-flat-file ;
IN: unicode.data
+<PRIVATE
+
VALUE: simple-lower
VALUE: simple-upper
VALUE: simple-title
VALUE: class-map
VALUE: compatibility-map
VALUE: category-map
-VALUE: name-map
VALUE: special-casing
VALUE: properties
-: canonical-entry ( char -- seq ) canonical-map at ;
-: combine-chars ( a b -- char/f ) combine-map hash2 ;
-: compatibility-entry ( char -- seq ) compatibility-map at ;
-: combining-class ( char -- n ) class-map at ;
-: non-starter? ( char -- ? ) combining-class { 0 f } member? not ;
-: name>char ( name -- char ) name-map at ;
-: char>name ( char -- name ) name-map value-at ;
-: property? ( char property -- ? ) properties at interval-key? ;
+PRIVATE>
-! Loading data from UnicodeData.txt
+VALUE: name-map
+
+: canonical-entry ( char -- seq ) canonical-map at ; inline
+: combine-chars ( a b -- char/f ) combine-map hash2 ; inline
+: compatibility-entry ( char -- seq ) compatibility-map at ; inline
+: combining-class ( char -- n ) class-map at ; inline
+: non-starter? ( char -- ? ) combining-class { 0 f } member? not ; inline
+: name>char ( name -- char ) name-map at ; inline
+: char>name ( char -- name ) name-map value-at ; inline
+: property? ( char property -- ? ) properties at interval-key? ; inline
+: ch>lower ( ch -- lower ) simple-lower at-default ; inline
+: ch>upper ( ch -- upper ) simple-upper at-default ; inline
+: ch>title ( ch -- title ) simple-title at-default ; inline
+: special-case ( ch -- casing-tuple ) special-casing at ; inline
+
+! For non-existent characters, use Cn
+CONSTANT: categories
+ { "Cn"
+ "Lu" "Ll" "Lt" "Lm" "Lo"
+ "Mn" "Mc" "Me"
+ "Nd" "Nl" "No"
+ "Pc" "Pd" "Ps" "Pe" "Pi" "Pf" "Po"
+ "Sm" "Sc" "Sk" "So"
+ "Zs" "Zl" "Zp"
+ "Cc" "Cf" "Cs" "Co" }
-: split-; ( line -- array )
- ";" split [ [ blank? ] trim ] map ;
+<PRIVATE
-: data ( filename -- data )
- ascii file-lines [ split-; ] map ;
+MEMO: categories-map ( -- hashtable )
+ categories <enum> [ swap ] H{ } assoc-map-as ;
+
+CONSTANT: num-chars HEX: 2FA1E
+
+PRIVATE>
+
+: category# ( char -- category )
+ ! There are a few characters that should be Cn
+ ! that this gives Cf or Mn
+ ! Cf = 26; Mn = 5; Cn = 29
+ ! Use a compressed array instead?
+ dup category-map ?nth [ ] [
+ dup HEX: E0001 HEX: E007F between?
+ [ drop 26 ] [
+ HEX: E0100 HEX: E01EF between? 5 29 ?
+ ] if
+ ] ?if ;
+
+: category ( char -- category )
+ category# categories nth ;
+
+<PRIVATE
+
+! Loading data from UnicodeData.txt
: load-data ( -- data )
"vocab:unicode/data/UnicodeData.txt" data ;
-: filter-comments ( lines -- lines )
- [ "#@" split first ] map harvest ;
-
: (process-data) ( index data -- newdata )
- filter-comments
[ [ nth ] keep first swap ] with { } map>assoc
[ [ hex> ] dip ] assoc-map ;
[ nip zero? not ] assoc-filter
>hashtable ;
-! For non-existent characters, use Cn
-CONSTANT: categories
- { "Cn"
- "Lu" "Ll" "Lt" "Lm" "Lo"
- "Mn" "Mc" "Me"
- "Nd" "Nl" "No"
- "Pc" "Pd" "Ps" "Pe" "Pi" "Pf" "Po"
- "Sm" "Sc" "Sk" "So"
- "Zs" "Zl" "Zp"
- "Cc" "Cf" "Cs" "Co" }
-
-MEMO: categories-map ( -- hashtable )
- categories <enum> [ swap ] H{ } assoc-map-as ;
-
-CONSTANT: num-chars HEX: 2FA1E
-
! the maximum unicode char in the first 3 planes
: ?set-nth ( val index seq -- )
: multihex ( hexstring -- string )
" " split [ hex> ] map sift ;
+PRIVATE>
+
TUPLE: code-point lower title upper ;
C: <code-point> code-point
+<PRIVATE
+
: set-code-point ( seq -- )
4 head [ multihex ] map first4
<code-point> swap first set ;
! Extra properties
-: properties-lines ( -- lines )
- "vocab:unicode/data/PropList.txt"
- ascii file-lines ;
-
: parse-properties ( -- {{[a,b],prop}} )
- properties-lines filter-comments [
- split-; first2
- [ ".." split1 [ dup ] unless* [ hex> ] bi@ 2array ] dip
- ] { } map>assoc ;
+ "vocab:unicode/data/PropList.txt" data [
+ [
+ ".." split1 [ dup ] unless*
+ [ hex> ] bi@ 2array
+ ] dip
+ ] assoc-map ;
: properties>intervals ( properties -- assoc[str,interval] )
dup values prune [ f ] H{ } map>assoc
load-properties to: properties
-! Utility to load resource files that look like Scripts.txt
+[ name>char [ "Invalid character" throw ] unless* ]
+name>char-hook set-global
SYMBOL: interned
-: parse-script ( filename -- assoc )
- ! assoc is code point/range => name
- ascii file-lines filter-comments [ split-; ] map ;
-
: range, ( value key -- )
swap interned get
[ = ] with find nip 2array , ;
] assoc-each
] { } make <interval-map> ;
-: process-script ( ranges -- table )
+: process-key-value ( ranges -- table )
dup values prune interned
[ expand-ranges ] with-variable ;
-: load-script ( filename -- table )
- parse-script process-script ;
+PRIVATE>
-[ name>char [ "Invalid character" throw ] unless* ]
-name>char-hook set-global
+: load-key-value ( filename -- table )
+ data process-key-value ;
USING: unicode.normalize kernel tools.test sequences
-unicode.data io.encodings.utf8 io.files splitting math.parser
+simple-flat-file io.encodings.utf8 io.files splitting math.parser
locals math quotations assocs combinators unicode.normalize.private ;
IN: unicode.normalize.tests
[ "\u00d55c" ] [ "\u001112\u001161\u0011ab" nfc ] unit-test
: parse-test ( -- tests )
- "vocab:unicode/normalize/NormalizationTest.txt"
- utf8 file-lines filter-comments
- [ ";" split 5 head [ " " split [ hex> ] "" map-as ] map ] map ;
+ "vocab:unicode/normalize/NormalizationTest.txt" data
+ [ 5 head [ " " split [ hex> ] "" map-as ] map ] map ;
:: assert= ( test spec quot -- )
spec [
-USING: help.syntax help.markup ;\r
+! Copyright (C) 2009 Daniel Ehrenberg\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: help.syntax help.markup strings ;\r
IN: unicode.script\r
\r
+ABOUT: "unicode.script"\r
+\r
+ARTICLE: "unicode.script" "Unicode script properties"\r
+"The unicode standard gives every character a script. Note that this is different from a language, and that it is non-trivial to detect language from a string. To get the script of a character, use"\r
+{ $subsection script-of } ;\r
+\r
HELP: script-of\r
-{ $values { "char" "a code point" } { "script" "a symbol" } }\r
-{ $description "Gets a symbol representing the code point of a given character. The word name of the symbol is the same as the one " } ;\r
+{ $values { "char" "a code point" } { "script" string } }\r
+{ $description "Finds the script of the given Unicode code point, represented as a string." } ;\r
unicode.data ;
IN: unicode.script
+<PRIVATE
+
VALUE: script-table
-"vocab:unicode/script/Scripts.txt" load-script
+"vocab:unicode/script/Scripts.txt" load-key-value
to: script-table
+PRIVATE>
+
: script-of ( char -- script )
script-table interval-at ;
assocs classes.predicate math.order strings.parser ;
IN: unicode.syntax
-! Character classes (categories)
-
-: category# ( char -- category )
- ! There are a few characters that should be Cn
- ! that this gives Cf or Mn
- ! Cf = 26; Mn = 5; Cn = 29
- ! Use a compressed array instead?
- dup category-map ?nth [ ] [
- dup HEX: E0001 HEX: E007F between?
- [ drop 26 ] [
- HEX: E0100 HEX: E01EF between? 5 29 ?
- ] if
- ] ?if ;
-
-: category ( char -- category )
- category# categories nth ;
+<PRIVATE
: >category-array ( categories -- bitarray )
categories [ swap member? ] with map >bit-array ;
: define-category ( word categories -- )
[category] integer swap define-predicate-class ;
+PRIVATE>
+
: CATEGORY:
CREATE ";" parse-tokens define-category ; parsing
{ $notes "This word is used by " { $link >url } ". It can also be used directly to parse " { $snippet "host:port" } " strings which are not full URLs." }
{ $examples
{ $example
- "USING: prettyprint urls kernel ;"
- "\"sbcl.org:80\" parse-host .s 2drop"
- "\"sbcl.org\"\n80"
+ "USING: arrays kernel prettyprint urls ;"
+ "\"sbcl.org:80\" parse-host 2array ."
+ "{ \"sbcl.org\" 80 }"
}
} ;
USING: kernel namespaces xml.name io.encodings.utf8 xml.elements
io.encodings.utf16 xml.tokenize xml.state math ascii sequences
io.encodings.string io.encodings combinators accessors
-xml.data io.encodings.iana ;
+xml.data io.encodings.iana xml.errors ;
IN: xml.autoencoding
: decode-stream ( encoding -- )
: prolog-encoding ( prolog -- )
encoding>> dup "UTF-16" =
- [ drop ] [ name>encoding [ decode-stream ] when* ] if ;
+ [ drop ] [
+ dup name>encoding
+ [ decode-stream ] [ bad-encoding ] ?if
+ ] if ;
: instruct-encoding ( instruct/prolog -- )
dup prolog?
USING: continuations xml xml.errors tools.test kernel arrays
-xml.data quotations fry ;
+xml.data quotations fry byte-arrays ;
IN: xml.errors.tests
: xml-error-test ( expected-error xml-string -- )
T{ disallowed-char f 1 4 1 } "<x>\u000001</x>" xml-error-test
T{ missing-close f 1 8 } "<!-- foo" xml-error-test
T{ misplaced-directive f 1 9 "ENTITY" } "<!ENTITY foo 'bar'><x/>" xml-error-test
+[ "<?xml version='1.0' encoding='foobar'?>" >byte-array bytes>xml ] [ T{ bad-encoding f 1 39 "foobar" } = ] must-fail-with
M: bad-doctype summary
call-next-method "\nDTD contains invalid object" append ;
+TUPLE: bad-encoding < xml-error-at encoding ;
+: bad-encoding ( encoding -- * )
+ \ bad-encoding xml-error-at
+ swap >>encoding
+ throw ;
+M: bad-encoding summary
+ call-next-method
+ "\nEncoding in XML document does not exist" append ;
+
UNION: xml-error
multitags notags pre/post-content xml-error-at ;
IN: vocabs.loader.test.2
-: hello 3 ;
+: hello ( -- ) ;
MAIN: hello
IN: vocabs.loader.tests
-[ { 3 3 3 } ] [
+[ ] [
"vocabs.loader.test.2" run
"vocabs.loader.test.2" vocab run
"vocabs.loader.test.2" <vocab-link> run
- 3array
] unit-test
-
[
"resource:core/vocabs/loader/test/a/a.factor" forget-source
"vocabs.loader.test.a" forget-vocab
in-advice? get [ "ad-do-it should only be called inside 'around' advice" throw ] unless coyield ;
: make-advised ( word -- )
- [ dup [ over dup '[ _ call-before _ _ call-around _ call-after ] ] annotate ]
+ [ dup '[ [ _ ] dip over dup '[ _ call-before _ _ call-around _ call-after ] ] annotate ]
[ { before after around } [ <linked-hash> swap set-word-prop ] with each ]
[ t advised set-word-prop ] tri ;
--- /dev/null
+USING: tools.deploy.config ;
+H{
+ { deploy-word-defs? f }
+ { deploy-word-props? f }
+ { deploy-math? f }
+ { deploy-compiler? t }
+ { deploy-ui? f }
+ { deploy-c-types? f }
+ { "stop-after-last-window?" t }
+ { deploy-reflection 1 }
+ { deploy-name "benchmark.regex-dna" }
+ { deploy-io 2 }
+ { deploy-threads? f }
+ { deploy-unicode? f }
+}
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors prettyprint io io.encodings.ascii
-io.files kernel sequences assocs namespaces regexp ;
+USING: accessors io io.encodings.ascii io.files kernel sequences
+assocs math.parser namespaces regexp ;
IN: benchmark.regex-dna
! Based on http://shootout.alioth.debian.org/gp4/benchmark.php?test=regexdna&lang=ruby&id=1
R/ agggtaa[cgt]|[acg]ttaccct/i
} [
[ raw>> write bl ]
- [ count-matches . ]
+ [ count-matches number>string print ]
bi
] with each ;
dup count-patterns
do-replacements
nl
- ilen get .
- clen get .
- length . ;
+ ilen get number>string print
+ clen get number>string print
+ length number>string print ;
: regex-dna-main ( -- )
"resource:extra/benchmark/regex-dna/regex-dna-test-in.txt" regex-dna ;
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.ranges sequences ;
+USING: kernel math math.ranges sequences project-euler.common ;
IN: project-euler.001
! http://projecteuler.net/index.php?section=problems&id=1
! [ euler001b ] 100 ave-time
! 0 ms run / 0 ms GC ave time - 100 trials
-MAIN: euler001
+SOLUTION: euler001
! Copyright (c) 2007, 2008 Aaron Schaefer, Alexander Solovyov, Vishal Talwar.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences ;
+USING: kernel math sequences project-euler.common ;
IN: project-euler.002
! http://projecteuler.net/index.php?section=problems&id=2
! [ euler002b ] 100 ave-time
! 0 ms ave run time - 0.0 SD (100 trials)
-MAIN: euler002b
+SOLUTION: euler002b
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: math.primes.factors sequences ;
+USING: math.primes.factors sequences project-euler.common ;
IN: project-euler.003
! http://projecteuler.net/index.php?section=problems&id=3
! [ euler003 ] 100 ave-time
! 1 ms ave run time - 0.49 SD (100 trials)
-MAIN: euler003
+SOLUTION: euler003
! [ euler004 ] 100 ave-time
! 1164 ms ave run time - 39.35 SD (100 trials)
-MAIN: euler004
+SOLUTION: euler004
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: math math.functions sequences ;
+USING: math math.functions sequences project-euler.common ;
IN: project-euler.005
! http://projecteuler.net/index.php?section=problems&id=5
! [ euler005 ] 100 ave-time
! 0 ms ave run time - 0.14 SD (100 trials)
-MAIN: euler005
+SOLUTION: euler005
! Copyright (c) 2007, 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.ranges sequences ;
+USING: kernel math math.ranges sequences project-euler.common ;
IN: project-euler.006
! http://projecteuler.net/index.php?section=problems&id=6
! [ euler006 ] 100 ave-time
! 0 ms ave run time - 0.24 SD (100 trials)
-MAIN: euler006
+SOLUTION: euler006
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: lists math math.primes.lists ;
+USING: lists math math.primes.lists project-euler.common ;
IN: project-euler.007
! http://projecteuler.net/index.php?section=problems&id=7
! [ euler007 ] 100 ave-time
! 5 ms ave run time - 1.13 SD (100 trials)
-MAIN: euler007
+SOLUTION: euler007
! Copyright (c) 2007, 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: grouping math.order math.parser sequences ;
+USING: grouping math.order math.parser sequences project-euler.common ;
IN: project-euler.008
! http://projecteuler.net/index.php?section=problems&id=8
! [ euler008 ] 100 ave-time
! 2 ms ave run time - 0.79 SD (100 trials)
-MAIN: euler008
+SOLUTION: euler008
! Copyright (c) 2007, 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel make math sequences sorting ;
+USING: kernel make math sequences sorting project-euler.common ;
IN: project-euler.009
! http://projecteuler.net/index.php?section=problems&id=9
! [ euler009 ] 100 ave-time
! 1 ms ave run time - 0.73 SD (100 trials)
-MAIN: euler009
+SOLUTION: euler009
! Copyright (c) 2007 Aaron Schaefer, Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: math.primes sequences ;
+USING: math.primes sequences project-euler.common ;
IN: project-euler.010
! http://projecteuler.net/index.php?section=problems&id=10
! [ euler010 ] 100 ave-time
! 15 ms ave run time - 0.41 SD (100 trials)
-MAIN: euler010
+SOLUTION: euler010
! Copyright (c) 2007, 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: grouping kernel make math.order sequences ;
+USING: grouping kernel make math.order sequences project-euler.common ;
IN: project-euler.011
! http://projecteuler.net/index.php?section=problems&id=11
! [ euler011 ] 100 ave-time
! 3 ms ave run time - 0.77 SD (100 trials)
-MAIN: euler011
+SOLUTION: euler011
! [ euler012 ] 10 ave-time
! 6573 ms ave run time - 346.27 SD (10 trials)
-MAIN: euler012
+SOLUTION: euler012
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: math.parser sequences ;
+USING: math.parser sequences project-euler.common ;
IN: project-euler.013
! http://projecteuler.net/index.php?section=problems&id=13
! [ euler013 ] 100 ave-time
! 0 ms ave run time - 0.31 SD (100 trials)
-MAIN: euler013
+SOLUTION: euler013
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.short-circuit kernel make math math.ranges sequences ;
+USING: combinators.short-circuit kernel make math math.ranges
+sequences project-euler.common ;
IN: project-euler.014
! http://projecteuler.net/index.php?section=problems&id=14
! TODO: try using memoization
-MAIN: euler014a
+SOLUTION: euler014a
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.combinatorics ;
+USING: kernel math math.combinatorics project-euler.common ;
IN: project-euler.015
! http://projecteuler.net/index.php?section=problems&id=15
! [ euler015 ] 100 ave-time
! 0 ms ave run time - 0.2 SD (100 trials)
-MAIN: euler015
+SOLUTION: euler015
! [ euler016 ] 100 ave-time
! 0 ms ave run time - 0.67 SD (100 trials)
-MAIN: euler016
+SOLUTION: euler016
! Copyright (c) 2007, 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: ascii kernel math.ranges math.text.english sequences ;
+USING: ascii kernel math.ranges math.text.english sequences
+project-euler.common ;
IN: project-euler.017
! http://projecteuler.net/index.php?section=problems&id=17
! [ euler017 ] 100 ave-time
! 15 ms ave run time - 1.71 SD (100 trials)
-MAIN: euler017
+SOLUTION: euler017
! [ euler018a ] 100 ave-time
! 0 ms ave run time - 0.39 SD (100 trials)
-MAIN: euler018a
+SOLUTION: euler018a
! Copyright (c) 2007 Samuel Tardieu, Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: calendar combinators kernel math math.ranges namespaces sequences
- math.order ;
+ math.order project-euler.common ;
IN: project-euler.019
! http://projecteuler.net/index.php?section=problems&id=19
! [ euler019a ] 100 ave-time
! 17 ms ave run time - 2.13 SD (100 trials)
-MAIN: euler019
+SOLUTION: euler019
! [ euler020 ] 100 ave-time
! 0 ms ave run time - 0.55 (100 trials)
-MAIN: euler020
+SOLUTION: euler020
! [ euler021 ] 100 ave-time
! 335 ms ave run time - 18.63 SD (100 trials)
-MAIN: euler021
+SOLUTION: euler021
! [ euler022 ] 100 ave-time
! 74 ms ave run time - 5.13 SD (100 trials)
-MAIN: euler022
+SOLUTION: euler022
! [ euler023 ] time
! 52780 ms run / 3839 ms GC
-MAIN: euler023
+SOLUTION: euler023
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math.combinatorics math.parser ;
+USING: kernel math.combinatorics math.parser project-euler.common ;
IN: project-euler.024
! http://projecteuler.net/index.php?section=problems&id=24
! [ euler024 ] 100 ave-time
! 0 ms ave run time - 0.27 SD (100 trials)
-MAIN: euler024
+SOLUTION: euler024
! [ euler025a ] 100 ave-time
! 0 ms ave run time - 0.17 SD (100 trials)
-MAIN: euler025a
+SOLUTION: euler025a
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions math.primes math.ranges sequences ;
+USING: kernel math math.functions math.primes math.ranges sequences project-euler.common ;
IN: project-euler.026
! http://projecteuler.net/index.php?section=problems&id=26
! [ euler026 ] 100 ave-time
! 290 ms ave run time - 19.2 SD (100 trials)
-MAIN: euler026
+SOLUTION: euler026
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.primes project-euler.common sequences ;
+USING: kernel math math.primes project-euler.common sequences
+project-euler.common ;
IN: project-euler.027
! http://projecteuler.net/index.php?section=problems&id=27
! TODO: generalize max-consecutive/max-product (from #26) into a new word
-MAIN: euler027
+SOLUTION: euler027
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.ranges sequences ;
+USING: kernel math math.ranges sequences project-euler.common ;
IN: project-euler.028
! http://projecteuler.net/index.php?section=problems&id=28
! [ euler028 ] 100 ave-time
! 0 ms ave run time - 0.39 SD (100 trials)
-MAIN: euler028
+SOLUTION: euler028
! [ euler029 ] 100 ave-time
! 704 ms ave run time - 28.07 SD (100 trials)
-MAIN: euler029
+SOLUTION: euler029
! [ euler030 ] 100 ave-time
! 1700 ms ave run time - 64.84 SD (100 trials)
-MAIN: euler030
+SOLUTION: euler030
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math ;
+USING: kernel math project-euler.common ;
IN: project-euler.031
! http://projecteuler.net/index.php?section=problems&id=31
! TODO: generalize to eliminate duplication; use a sequence to specify denominations?
-MAIN: euler031
+SOLUTION: euler031
! [ euler032a ] 10 ave-time
! 2624 ms ave run time - 131.91 SD (10 trials)
-MAIN: euler032a
+SOLUTION: euler032a
! [ euler033 ] 100 ave-time
! 7 ms ave run time - 1.31 SD (100 trials)
-MAIN: euler033
+SOLUTION: euler033
! [ euler034 ] 10 ave-time
! 5506 ms ave run time - 144.0 SD (10 trials)
-MAIN: euler034
+SOLUTION: euler034
! TODO: try using bit arrays or other methods outlined here:
! http://home.comcast.net/~babdulbaki/Circular_Primes.html
-MAIN: euler035
+SOLUTION: euler035
! [ euler036 ] 100 ave-time
! 1703 ms ave run time - 96.6 SD (100 trials)
-MAIN: euler036
+SOLUTION: euler036
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.parser math.primes sequences ;
+USING: kernel math math.parser math.primes sequences project-euler.common ;
IN: project-euler.037
! http://projecteuler.net/index.php?section=problems&id=37
! [ euler037 ] 100 ave-time
! 130 ms ave run time - 6.27 SD (100 trials)
-MAIN: euler037
+SOLUTION: euler037
! [ euler038 ] 100 ave-time
! 11 ms ave run time - 1.5 SD (100 trials)
-MAIN: euler038
+SOLUTION: euler038
! [ euler039 ] 100 ave-time
! 1 ms ave run time - 0.37 SD (100 trials)
-MAIN: euler039
+SOLUTION: euler039
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.parser sequences strings ;
+USING: kernel math math.parser sequences strings project-euler.common ;
IN: project-euler.040
! http://projecteuler.net/index.php?section=problems&id=40
! [ euler040 ] 100 ave-time
! 444 ms ave run time - 23.64 SD (100 trials)
-MAIN: euler040
+SOLUTION: euler040
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math.combinatorics math.parser math.primes sequences ;
+USING: kernel math.combinatorics math.parser math.primes sequences project-euler.common ;
IN: project-euler.041
! http://projecteuler.net/index.php?section=problems&id=41
! [ euler041 ] 100 ave-time
! 64 ms ave run time - 4.22 SD (100 trials)
-MAIN: euler041
+SOLUTION: euler041
! [ euler042a ] 100 ave-time
! 21 ms ave run time - 2.2 SD (100 trials)
-MAIN: euler042a
+SOLUTION: euler042a
! [ euler043a ] 100 ave-time
! 10 ms ave run time - 1.37 SD (100 trials)
-MAIN: euler043a
+SOLUTION: euler043a
! TODO: this solution is ugly and not very efficient...find a better algorithm
-MAIN: euler044
+SOLUTION: euler044
! [ euler045 ] 100 ave-time
! 12 ms ave run time - 1.71 SD (100 trials)
-MAIN: euler045
+SOLUTION: euler045
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions math.primes math.ranges sequences ;
+USING: kernel math math.functions math.primes math.ranges sequences project-euler.common ;
IN: project-euler.046
! http://projecteuler.net/index.php?section=problems&id=46
! [ euler046 ] 100 ave-time
! 37 ms ave run time - 3.39 SD (100 trials)
-MAIN: euler046
+SOLUTION: euler046
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math math.primes math.primes.factors
- math.ranges namespaces sequences ;
+ math.ranges namespaces sequences project-euler.common ;
IN: project-euler.047
! http://projecteuler.net/index.php?section=problems&id=47
! TODO: I don't like that you have to specify the upper bound, maybe try making
! this lazy so it could also short-circuit when it finds the answer?
-MAIN: euler047a
+SOLUTION: euler047a
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions sequences ;
+USING: kernel math math.functions sequences project-euler.common ;
IN: project-euler.048
! http://projecteuler.net/index.php?section=problems&id=48
! [ euler048 ] 100 ave-time
! 276 ms run / 1 ms GC ave time - 100 trials
-MAIN: euler048
+SOLUTION: euler048
! [ euler050 ] 100 ave-time
! 291 ms run / 20.6 ms GC ave time - 100 trials
-MAIN: euler050
+SOLUTION: euler050
! [ euler052 ] 100 ave-time
! 92 ms ave run time - 6.29 SD (100 trials)
-MAIN: euler052
+SOLUTION: euler052
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.combinatorics math.ranges sequences ;
+USING: kernel math math.combinatorics math.ranges sequences project-euler.common ;
IN: project-euler.053
! http://projecteuler.net/index.php?section=problems&id=53
! [ euler053 ] 100 ave-time
! 52 ms ave run time - 4.44 SD (100 trials)
-MAIN: euler053
+SOLUTION: euler053
! [ euler055 ] 100 ave-time
! 478 ms ave run time - 30.63 SD (100 trials)
-MAIN: euler055
+SOLUTION: euler055
! [ euler056 ] 100 ave-time
! 22 ms ave run time - 2.13 SD (100 trials)
-MAIN: euler056
+SOLUTION: euler056
! Copyright (c) 2008 Samuel Tardieu
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions math.parser sequences ;
+USING: kernel math math.functions math.parser sequences project-euler.common ;
IN: project-euler.057
! http://projecteuler.net/index.php?section=problems&id=57
! [ euler057 ] time
! 3.375118 seconds
-MAIN: euler057
+SOLUTION: euler057
! See http://factorcode.org/license.txt for BSD license.
USING: arrays ascii assocs hashtables io.encodings.ascii io.files kernel math
math.parser namespaces make sequences sequences.private sorting
- splitting grouping strings sets accessors ;
+ splitting grouping strings sets accessors project-euler.common ;
IN: project-euler.059
! http://projecteuler.net/index.php?section=problems&id=59
! [ euler059 ] 100 ave-time
! 8 ms ave run time - 1.4 SD (100 trials)
-MAIN: euler059
+SOLUTION: euler059
! [ euler067a ] 100 ave-time
! 21 ms ave run time - 2.65 SD (100 trials)
-MAIN: euler067a
+SOLUTION: euler067a
! [ euler071 ] 100 ave-time
! 155 ms ave run time - 6.95 SD (100 trials)
-MAIN: euler071
+SOLUTION: euler071
! [ euler073 ] 10 ave-time
! 20506 ms ave run time - 937.07 SD (10 trials)
-MAIN: euler073
+SOLUTION: euler073
! [ euler075 ] 10 ave-time
! 3341 ms ave run timen - 157.77 SD (10 trials)
-MAIN: euler075
+SOLUTION: euler075
! Copyright (c) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs kernel locals math math.order math.ranges sequences ;
+USING: arrays assocs kernel locals math math.order math.ranges sequences project-euler.common ;
IN: project-euler.076
! http://projecteuler.net/index.php?section=problems&id=76
! [ euler076 ] 100 ave-time
! 560 ms ave run time - 17.74 SD (100 trials)
-MAIN: euler076
+SOLUTION: euler076
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs io.encodings.ascii io.files kernel make math math.parser
- sequences sets ;
+ sequences sets project-euler.common ;
IN: project-euler.079
! http://projecteuler.net/index.php?section=problems&id=79
! TODO: prune and diff are relatively slow; topological sort could be
! cleaned up and generalized much better, but it works for this problem
-MAIN: euler079
+SOLUTION: euler079
! TODO: this solution is not very efficient, much better optimizations exist
-MAIN: euler092
+SOLUTION: euler092
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: math math.functions ;
+USING: math math.functions project-euler.common ;
IN: project-euler.097
! http://projecteuler.net/index.php?section=problems&id=97
! [ euler097 ] 100 ave-time
! 0 ms ave run timen - 0.22 SD (100 trials)
-MAIN: euler097
+SOLUTION: euler097
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: io.encodings.ascii io.files kernel math math.functions math.parser
- math.vectors sequences splitting ;
+ math.vectors sequences splitting project-euler.common ;
IN: project-euler.099
! http://projecteuler.net/index.php?section=problems&id=99
! [ euler099 ] 100 ave-time
! 16 ms ave run timen - 1.67 SD (100 trials)
-MAIN: euler099
+SOLUTION: euler099
! Copyright (c) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions sequences ;
+USING: kernel math math.functions sequences project-euler.common ;
IN: project-euler.100
! http://projecteuler.net/index.php?section=problems&id=100
! [ euler100 ] 100 ave-time
! 0 ms ave run time - 0.14 SD (100 trials)
-MAIN: euler100
+SOLUTION: euler100
! Copyright (c) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.ranges sequences ;
+USING: kernel math math.ranges sequences project-euler.common ;
IN: project-euler.116
! http://projecteuler.net/index.php?section=problems&id=116
! [ euler116 ] 100 ave-time
! 0 ms ave run time - 0.34 SD (100 trials)
-MAIN: euler116
+SOLUTION: euler116
! Copyright (c) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.order sequences splitting ;
+USING: kernel math math.order sequences splitting project-euler.common ;
IN: project-euler.117
! http://projecteuler.net/index.php?section=problems&id=117
! [ euler117 ] 100 ave-time
! 0 ms ave run time - 0.29 SD (100 trials)
-MAIN: euler117
+SOLUTION: euler117
! [ euler134 ] 10 ave-time
! 933 ms ave run timen - 19.58 SD (10 trials)
-MAIN: euler134
+SOLUTION: euler134
! Copyright (c) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions sequences ;
+USING: kernel math math.functions sequences project-euler.common ;
IN: project-euler.148
! http://projecteuler.net/index.php?section=problems&id=148
! [ euler148 ] 100 ave-time
! 0 ms ave run time - 0.17 SD (100 trials)
-MAIN: euler148
+SOLUTION: euler148
! Copyright (c) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license.
-USING: hints kernel locals math math.order sequences sequences.private ;
+USING: hints kernel locals math math.order sequences sequences.private project-euler.common ;
IN: project-euler.150
! http://projecteuler.net/index.php?section=problems&id=150
! [ euler150 ] 10 ave-time
! 30208 ms ave run time - 593.45 SD (10 trials)
-MAIN: euler150
+SOLUTION: euler150
! Copyright (c) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs combinators kernel math math.order namespaces sequences ;
+USING: assocs combinators kernel math math.order namespaces sequences project-euler.common ;
IN: project-euler.151
! http://projecteuler.net/index.php?section=problems&id=151
! [ euler151 ] 100 ave-time
! ? ms run time - 100 trials
-MAIN: euler151
+SOLUTION: euler151
! Copyright (c) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs kernel math math.ranges sequences ;
+USING: arrays assocs kernel math math.ranges sequences project-euler.common ;
IN: project-euler.164
! http://projecteuler.net/index.php?section=problems&id=164
! [ euler164 ] 100 ave-time
! 7 ms ave run time - 1.23 SD (100 trials)
-MAIN: euler164
+SOLUTION: euler164
! Copyright (c) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
IN: project-euler.169
-USING: combinators kernel math math.functions memoize ;
+USING: combinators kernel math math.functions memoize project-euler.common ;
! http://projecteuler.net/index.php?section=problems&id=169
! [ euler169 ] 100 ave-time
! 0 ms ave run time - 0.2 SD (100 trials)
-MAIN: euler169
+SOLUTION: euler169
! Copyright (c) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions math.ranges sequences ;
+USING: kernel math math.functions math.ranges sequences project-euler.common ;
IN: project-euler.173
! http://projecteuler.net/index.php?section=problems&id=173
! [ euler173 ] 100 ave-time
! 0 ms ave run time - 0.35 SD (100 trials)
-MAIN: euler173
+SOLUTION: euler173
! Copyright (c) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel math math.parser math.ranges sequences vectors ;
+USING: combinators kernel math math.parser math.ranges sequences vectors project-euler.common ;
IN: project-euler.175
! http://projecteuler.net/index.php?section=problems&id=175
! [ euler175 ] 100 ave-time
! 0 ms ave run time - 0.31 SD (100 trials)
-MAIN: euler175
+SOLUTION: euler175
! Copyright (c) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license.
-USING: circular disjoint-sets kernel math math.ranges sequences ;
+USING: circular disjoint-sets kernel math math.ranges sequences project-euler.common ;
IN: project-euler.186
! http://projecteuler.net/index.php?section=problems&id=186
! [ euler186 ] 10 ave-time
! 18572 ms ave run time - 796.87 SD (10 trials)
-MAIN: euler186
+SOLUTION: euler186
! Copyright (c) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences math math.functions math.ranges locals ;
+USING: kernel sequences math math.functions math.ranges locals project-euler.common ;
IN: project-euler.190
! http://projecteuler.net/index.php?section=problems&id=190
! [ euler150 ] 100 ave-time
! 5 ms ave run time - 1.01 SD (100 trials)
-MAIN: euler190
+SOLUTION: euler190
! Copyright (c) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license.
-USING: fry kernel math math.primes.factors sequences sets ;
+USING: fry kernel math math.primes.factors sequences sets project-euler.common ;
IN: project-euler.203
! http://projecteuler.net/index.php?section=problems&id=203
! [ euler203 ] 100 ave-time
! 12 ms ave run time - 1.6 SD (100 trials)
-MAIN: euler203
+SOLUTION: euler203
! Copyright (c) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel locals math ;
+USING: accessors kernel locals math project-euler.common ;
IN: project-euler.215
! http://projecteuler.net/index.php?section=problems&id=215
! [ euler215 ] 100 ave-time
! 208 ms ave run time - 9.06 SD (100 trials)
-MAIN: euler215
+SOLUTION: euler215
! 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 ;
+ sequences sorting strings unicode.case parser accessors vocabs.parser
+ namespaces vocabs words quotations prettyprint ;
IN: project-euler.common
! A collection of words used by more than one Project Euler solution
: d-transform ( triple -- new-triple )
{ { -1 -2 -2 } { 2 1 2 } { 2 2 3 } } transform ;
+: SOLUTION:
+ scan-word
+ [ name>> "-main" append create-in ] keep
+ [ drop in get vocab (>>main) ]
+ [ [ . ] swap prefix (( -- )) define-declared ]
+ 2bi ; parsing
+
: run-project-euler ( -- )
problem-prompt dup problem-solved? [
+ "Answer: " write
dup number>euler "project-euler." prepend run
- "Answer: " write dup number? [ number>string ] when print
"Source: " write solution-path .
] [
drop "That problem has not been solved yet..." print
-Doug Coleman
+Doug Coleman
\ No newline at end of file
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! 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 ;
+IN: site-watcher.db
+
+TUPLE: account account-id account-name email ;
+
+: <account> ( account-name -- account )
+ account new
+ swap >>account-name ;
+
+account "ACCOUNT" {
+ { "account-name" "ACCOUNT_NAME" VARCHAR +user-assigned-id+ }
+ { "email" "EMAIL" VARCHAR }
+} define-persistent
+
+TUPLE: site site-id url up? changed? last-up error last-error ;
+
+: <site> ( url -- site )
+ site new
+ swap >>url ;
+
+site "SITE" {
+ { "site-id" "SITE_ID" INTEGER +db-assigned-id+ }
+ { "url" "URL" VARCHAR }
+ { "up?" "UP" BOOLEAN }
+ { "changed?" "CHANGED" BOOLEAN }
+ { "last-up" "LAST_UP" TIMESTAMP }
+ { "error" "ERROR" VARCHAR }
+ { "last-error" "LAST_ERROR" TIMESTAMP }
+} define-persistent
+
+TUPLE: watching-site account-name site-id ;
+
+: <watching-site> ( account-name site-id -- watching-site )
+ watching-site new
+ swap >>site-id
+ swap >>account-name ;
+
+watching-site "WATCHING_SITE" {
+ { "account-name" "ACCOUNT_NAME" VARCHAR +user-assigned-id+ }
+ { "site-id" "SITE_ID" INTEGER +user-assigned-id+ }
+} define-persistent
+
+TUPLE: reporting-site email url up? changed? last-up? error last-error ;
+
+<PRIVATE
+
+: set-notify-site-watchers ( site new-up? -- site )
+ [ over up?>> = [ t >>changed? ] unless ] keep >>up? ;
+
+: site-good ( site -- )
+ t set-notify-site-watchers
+ now >>last-up
+ f >>error
+ f >>last-error
+ update-tuple ;
+
+: site-bad ( site error -- )
+ [ error. ] with-string-writer >>error
+ f set-notify-site-watchers
+ now >>last-error
+ update-tuple ;
+
+: sites-to-report ( -- seq )
+ "select account.email, site.url, site.up, site.changed, site.last_up, site.error, site.last_error from account, site, watching_site where account.account_name = watching_site.account_name and site.site_id = watching_site.site_id and site.changed = '1'" sql-query
+ [ [ reporting-site boa ] input<sequence ] map
+ "update site set changed = 'f';" sql-command ;
+
+: insert-site ( url -- site )
+ <site> dup select-tuple [ ] [ dup t >>up? insert-tuple ] ?if ;
+
+: insert-account ( account-name -- ) <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 ;
+
+: unwatch-site ( username url -- )
+ select-account/site <watching-site> delete-tuples ;
+
+: watching-sites ( username -- sites )
+ f <watching-site> select-tuples
+ [ site-id>> site new swap >>site-id select-tuple ] map ;
+++ /dev/null
-! Copyright (C) 2009 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: assocs help.markup help.syntax kernel urls alarms calendar ;
-IN: site-watcher
-
-HELP: run-site-watcher
-{ $description "Starts the site-watcher on the assoc stored in " { $link sites } "." } ;
-
-HELP: running-site-watcher
-{ $var-description "A symbol storing the alarm of a running site-watcher if started with the " { $link run-site-watcher } " word. To prevent multiple site-watchers from running, this variable is checked before allowing another site-watcher to start." } ;
-
-HELP: site-watcher-from
-{ $var-description "The email address from which site-watcher sends emails." } ;
-
-HELP: sites
-{ $var-description "A symbol storing an assoc of URLs, data about a site, and who to notify if a site goes down." } ;
-
-HELP: watch-site
-{ $values
- { "emails" "a string containing an email address, or an array of such" }
- { "url" url }
-}
-{ $description "Adds a new site to the watch assoc stored in " { $link sites } ", or adds email addresses to an already watched site." } ;
-
-HELP: watch-sites
-{ $values
- { "assoc" assoc }
- { "alarm" alarm }
-}
-{ $description "Runs the site-watcher on the input assoc and returns the alarm that times the site check loop. This alarm may be turned off with " { $link cancel-alarm } ", thus stopping the site-watcher." } ;
-
-HELP: site-watcher-frequency
-{ $var-description "A " { $link duration } " specifying how long to wait between checking sites." } ;
-
-HELP: unwatch-site
-{ $values
- { "emails" "a string containing an email, or an array of such" }
- { "url" url }
-}
-{ $description "Removes an email address from being notified when a site's goes down. If this email was the last one watching the site, removes the site as well." } ;
-
-HELP: delete-site
-{ $values
- { "url" url }
-}
-{ $description "Removes a watched site from the " { $link sites } " assoc." } ;
-
-ARTICLE: "site-watcher" "Site watcher"
-"The " { $vocab-link "site-watcher" } " vocabulary monitors websites and sends email when a site goes down or comes up." $nl
-"To monitor a site:"
-{ $subsection watch-site }
-"To stop email addresses from being notified if a site's status changes:"
-{ $subsection unwatch-site }
-"To stop monitoring a site for all email addresses:"
-{ $subsection delete-site }
-"To run site-watcher using the sites variable:"
-{ $subsection run-site-watcher }
-;
-
-ABOUT: "site-watcher"
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! 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 db.sqlite site-watcher.db.private ;
+IN: site-watcher.tests
+
+: site-watcher-path ( -- path ) "site-watcher.db" temp-file ; inline
+
+[ site-watcher-path delete-file ] ignore-errors
+
+: with-sqlite-db ( quot -- )
+ site-watcher-path <sqlite-db> swap with-db ; inline
+
+:: fake-sites ( -- seq )
+ [
+ account ensure-table
+ site ensure-table
+ watching-site ensure-table
+
+ "erg@factorcode.org" insert-account
+ "http://asdfasdfasdfasdfqwerqqq.com" insert-site drop
+ "http://fark.com" insert-site drop
+
+ "erg@factorcode.org" "http://asdfasdfasdfasdfqwerqqq.com" watch-site
+ f <site> select-tuples
+ ] with-sqlite-db ;
+
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alarms assocs calendar combinators
-continuations fry http.client io.streams.string kernel init
-namespaces prettyprint smtp arrays sequences math math.parser
-strings sets ;
+USING: accessors alarms arrays calendar combinators
+combinators.smart continuations debugger http.client
+init io.streams.string kernel locals math math.parser
+namespaces sequences site-watcher.db site-watcher.db.private smtp ;
IN: site-watcher
-SYMBOL: sites
-
SYMBOL: site-watcher-from
+"factor-site-watcher@gmail.com" site-watcher-from set-global
-sites [ H{ } clone ] initialize
-
-TUPLE: watching emails url last-up up? send-email? error ;
+SYMBOL: site-watcher-frequency
+10 seconds site-watcher-frequency set-global
+
+SYMBOL: running-site-watcher
+[ f running-site-watcher set-global ] "site-watcher" add-init-hook
<PRIVATE
-: ?1array ( array/object -- array )
- dup array? [ 1array ] unless ; inline
-
-: <watching> ( emails url -- watching )
- watching new
- swap >>url
- swap ?1array >>emails
- now >>last-up
- t >>up? ;
-
-ERROR: not-watching-site url status ;
-
-: set-site-flags ( watching new-up? -- watching )
- [ over up?>> = [ t >>send-email? ] unless ] keep >>up? ;
-
-: site-bad ( watching error -- )
- >>error f set-site-flags drop ;
-
-: site-good ( watching -- )
- f >>error
- t set-site-flags
- now >>last-up drop ;
-
-: check-sites ( assoc -- )
+: check-sites ( seq -- )
[
- swap '[ _ http-get 2drop site-good ] [ site-bad ] recover
- ] assoc-each ;
+ [ dup url>> http-get 2drop site-good ] [ site-bad ] recover
+ ] each ;
-: site-up-email ( email watching -- email )
+: site-up-email ( email site -- email )
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 ;
-: ?unparse ( string/object -- string )
- dup string? [ unparse ] unless ; inline
+: site-down-email ( email site -- email ) error>> >>body ;
-: site-down-email ( email watching -- email )
- error>> ?unparse >>body ;
-
-: send-report ( watching -- )
+: send-report ( site -- )
[ <email> ] dip
{
- [ emails>> >>to ]
+ [ 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 ]
- [ f >>send-email? drop ]
} cleave send-email ;
-: report-sites ( assoc -- )
- [ nip send-email?>> ] assoc-filter
- [ nip send-report ] assoc-each ;
+: send-reports ( seq -- )
+ [ ] [ [ send-report ] each ] if-empty ;
PRIVATE>
-SYMBOL: site-watcher-frequency
-site-watcher-frequency [ 5 minutes ] initialize
-
-: watch-sites ( assoc -- alarm )
- '[
- _ [ check-sites ] [ report-sites ] bi
- ] site-watcher-frequency get every ;
-
-: watch-site ( emails url -- )
- sites get ?at [
- [ [ ?1array ] dip append prune ] change-emails drop
- ] [
- <watching> dup url>> sites get set-at
- ] if ;
-
-: delete-site ( url -- )
- sites get delete-at ;
-
-: unwatch-site ( emails url -- )
- [ ?1array ] dip
- sites get ?at [
- [ diff ] change-emails dup emails>> empty? [
- url>> delete-site
- ] [
- drop
- ] if
- ] [
- nip delete-site
- ] if ;
-
-SYMBOL: running-site-watcher
+: watch-sites ( -- )
+ find-sites check-sites sites-to-report send-reports ;
: run-site-watcher ( -- )
- running-site-watcher get-global [
- sites get-global watch-sites running-site-watcher set-global
+ running-site-watcher get [
+ [ watch-sites ] site-watcher-frequency get every
+ running-site-watcher set-global
] unless ;
-[ f running-site-watcher set-global ] "site-watcher" add-init-hook
-
-MAIN: run-site-watcher
+: stop-site-watcher ( -- )
+ running-site-watcher get [ cancel-alarm ] when* ;
--- /dev/null
+<?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>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-<html>
- <head>
- <title>SiteWatcher</title>
- </head>
- <body>
- <h1>SiteWatcher</h1>
- <h2>It tells you if your web site goes down.</h2>
- <table>
- <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>
- <hr />
- <h3>Add a new site</h3>
- <t:form t:action="$site-watcher-app/add">
- <table>
- <tr>
- <th>URL:</th>
- <td> <t:field t:name="url" t:size="80" /> </td>
- </tr>
- <tr>
- <th>E-mail:</th>
- <td> <t:field t:name="email" t:size="80" /> </td>
- </tr>
- </table>
- <p> <button type="submit">Done</button> </p>
- </t:form>
- </body>
-</html>
+<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>
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors furnace.actions furnace.alloy furnace.redirection
-html.forms http.server http.server.dispatchers namespaces site-watcher
-site-watcher.private kernel urls validators db.sqlite assocs ;
+USING: accessors assocs db.sqlite furnace furnace.actions furnace.alloy
+furnace.auth furnace.auth.features.deactivate-user
+furnace.auth.features.edit-profile
+furnace.auth.features.recover-password
+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 ;
+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
[
- begin-form
- sites get values "sites" set-value
- ] >>init ;
+ ! Silly query
+ username watching-sites
+ "sites" set-value
+ ] >>init
+ <protected>
+ "list watched sites" >>description ;
: <add-site-action> ( -- action )
<action>
[
- { { "url" [ v-url ] } { "email" [ v-email ] } } validate-params
+ { { "url" [ v-url ] } } validate-params
] >>validate
[
- "email" value "url" value watch-site
+ username "url" value watch-site
site-list-url <redirect>
- ] >>submit ;
+ ] >>submit
+ <protected>
+ "add a watched site" >>description ;
: <remove-site-action> ( -- action )
<action>
{ { "url" [ v-url ] } } validate-params
] >>validate
[
- "url" value delete-site
+ username "url" value unwatch-site
site-list-url <redirect>
- ] >>submit ;
+ ] >>submit
+ <protected>
+ "remove a watched site" >>description ;
: <check-sites-action> ( -- action )
<action>
[
- sites get [ check-sites ] [ report-sites ] bi
+ watch-sites
+ site-list-url <redirect>
+ ] >>submit
+ <protected>
+ "check watched sites" >>description ;
+
+: <update-notify-action> ( -- action )
+ <page-action>
+ [
+ username <account> select-tuple from-object
+ ] >>init
+ { site-watcher-app "update-notify" } >>template
+ [
+ {
+ { "email" [ [ v-email ] v-optional ] }
+ { "twitter" [ [ v-one-word ] v-optional ] }
+ { "sms" [ [ v-one-line ] v-optional ] }
+ } validate-params
+ ] >>validate
+ [
+ username <account> select-tuple
+ "email" value >>email
+ update-tuple
site-list-url <redirect>
- ] >>submit ;
+ ] >>submit
+ <protected>
+ "update notification details" >>description ;
: <site-watcher-app> ( -- dispatcher )
site-watcher-app new-dispatcher
- <site-list-action> "" add-responder
+ <main-action> "" add-responder
+ <site-list-action> "list" add-responder
<add-site-action> "add" add-responder
<remove-site-action> "remove" add-responder
- <check-sites-action> "check" add-responder ;
+ <check-sites-action> "check" add-responder
+ <update-notify-action> "update-notify" add-responder ;
+
+: <login-config> ( responder -- responder' )
+ "SiteWatcher" <login-realm>
+ "SiteWatcher" >>name
+ allow-registration
+ allow-password-recovery
+ allow-edit-profile
+ allow-deactivation ;
+
+: <site-watcher-server> ( -- threaded-server )
+ <http-server>
+ <test-secure-config> >>secure-config
+ 8081 >>insecure
+ 8431 >>secure ;
+
+: site-watcher-db ( -- db )
+ "resource:test.db" <sqlite-db> ;
+
+<site-watcher-app>
+<login-config>
+<boilerplate> { site-watcher-app "site-watcher" } >>template
+site-watcher-db <alloy>
+main-responder set-global
+
+: start-site-watcher ( -- )
+ <site-watcher-server> start-server ;
-<site-watcher-app> "resource:test.db" <sqlite-db> <alloy> main-responder set-global
\ No newline at end of file
+: init-db ( -- )
+ site-watcher-db [
+ { site account watching-site } [ ensure-table ] each
+ ] with-db ;
\ No newline at end of file
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+<html>
+ <head>
+ <title>SiteWatcher</title>
+ </head>
+ <body>
+ <h1>SiteWatcher</h1>
+ <h2>It tells you if your web site goes down.</h2>
+ <t:call-next-template />
+ </body>
+</html>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+<h3>Enter your contact details</h3>
+
+<t:form t:action="$site-watcher-app/update-notify">
+<table>
+ <tr><th>E-mail:</th><td><t:field t:name="email" t:size="80" /></td></tr>
+ <tr><th>Twitter:</th><td><t:field t:name="twitter" t:size="80" /></td></tr>
+ <tr><th>SMS:</th><td><t:field t:name="sms" t:size="80" /></td></tr>
+</table>
+<p> <button type="submit">Done</button> </p>
+</t:form>
+
+</t:chloe>
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel
cocoa
cocoa.application
cocoa.types
cocoa.classes
-cocoa.windows ;
+cocoa.windows
+core-graphics.types ;
IN: webkit-demo
FRAMEWORK: /System/Library/Frameworks/WebKit.framework
IMPORT: WebView
-: rect ( -- rect ) 0 0 700 500 <NSRect> ;
+: rect ( -- rect ) 0 0 700 500 <CGRect> ;
: <WebView> ( -- id )
WebView -> alloc
USING: kernel sequences namespaces make math assocs words arrays
tools.annotations vocabs sorting prettyprint io system
-math.statistics accessors tools.time ;
+math.statistics accessors tools.time fry ;
IN: wordtimer
SYMBOL: *wordtimes*
[ swap time-unless-recursing ] 2curry ;
: add-timer ( word -- )
- dup [ (add-timer) ] annotate ;
+ dup '[ [ _ ] dip (add-timer) ] annotate ;
: add-timers ( vocab -- )
words [ add-timer ] each ;
(save-excursion
(goto-char (nth 8 state))
(beginning-of-line)
- (cond ((looking-at "USING: ")
+ (cond ((looking-at-p "USING: ")
'factor-font-lock-vocabulary-name)
- ((looking-at "\\(TUPLE\\|SYMBOLS\\|VARS\\): ")
+ ((looking-at-p "\\(TUPLE\\|SYMBOLS\\|VARS\\|SINGLETONS\\):")
'factor-font-lock-symbol)
- ((looking-at "C-ENUM:\\( \\|\n\\)")
+ ((looking-at-p "C-ENUM:\\( \\|\n\\)")
'factor-font-lock-constant)
(t 'default))))
((or (char-equal c ?U) (char-equal c ?C))
"\\_<\"[^>]\\([^\"\n]\\|\\\\\"\\)*\n")
(defconst fuel-syntax--word-definition-regex
- (fuel-syntax--second-word-regex
- '(":" "::" "GENERIC:" "DEFER:" "HOOK:" "MAIN:" "MATH:" "POSTPONE:"
- "SYMBOL:" "RENAME:")))
+ (format "\\_<\\(%s\\)?: +\\_<\\(\\w+\\)\\_>"
+ (regexp-opt
+ '(":" "GENERIC" "DEFER" "HOOK" "MAIN" "MATH" "POSTPONE"
+ "SYMBOL" "RENAME"))))
(defconst fuel-syntax--alias-definition-regex
"^ALIAS: +\\(\\_<.+?\\_>\\) +\\(\\_<.+?\\_>\\)")
(defconst fuel-syntax--indent-def-start-regex
(format "^\\(%s:\\)\\( \\|\n\\)" (regexp-opt fuel-syntax--indent-def-starts)))
-(defconst fuel-syntax--no-indent-def-start-regex
- (format "^\\(%s:\\) " (regexp-opt fuel-syntax--no-indent-def-starts)))
-
(defconst fuel-syntax--definition-start-regex
(format "^\\(%s:\\) " (regexp-opt (append fuel-syntax--no-indent-def-starts
fuel-syntax--indent-def-starts))))
("\\_<\\(C\\)-ENUM: \\(;\\)" (1 "<b") (2 ">b"))
("\\_<C-ENUM:\\( \\|\n\\)" (1 "<b"))
("\\_<TUPLE: +\\w+? +< +\\w+? *\\( \\|\n\\)\\([^;]\\|$\\)" (1 "<b"))
- ("\\_<\\(TUPLE\\|SYMBOLS\\|VARS\\): +\\w+? *\\( \\|\n\\)\\([^;<\n]\\|\\_>\\)"
- (2 "<b"))
+ ("\\_<TUPLE: +\\w+? *\\( \\|\n\\)\\([^;<\n]\\|\\_>\\)" (1 "<b"))
+ ("\\_<\\(SYMBOLS\\|VARS\\|SINGLETONS\\): *?\\( \\|\n\\)\\([^;\n]\\|\\_>\\)" (2 "<b"))
("\\(\n\\| \\);\\_>" (1 ">b"))
;; Let and lambda:
("\\_<\\(!(\\) .* \\()\\)" (1 "<") (2 ">"))
(defsubst fuel-syntax--is-last-char (pos)
(save-excursion
(goto-char (1+ pos))
- (fuel-syntax--looking-at-emptiness)))
+ (looking-at-p "[ ]*$")))
(defsubst fuel-syntax--line-offset (pos)
(- pos (save-excursion
projects / factor.git / commitdiff