steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge http://littledan.onigirihouse.com/factor

db4
Doug Coleman 2007-12-30 18:09:47 -06:00
parent 67fe34ba88 bea0eb759a
commit 95272f8a51
13 changed files with 174 additions and 118 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
extra/html/elements/elements.factor
View File

@ -4,7 +4,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: io kernel namespaces prettyprint quotations
sequences strings words ;
sequences strings words xml.writer ;
IN: html.elements
@ -123,7 +123,7 @@ SYMBOL: html
" " write-html
write-html
"='" write-html
write
escape-quoted-string write
"'" write-html ;
: define-attribute-word ( name -- )

6
extra/html/html.factor
View File

@ -142,7 +142,7 @@ M: html-block-stream stream-close ( quot style stream -- )
table-style " border-collapse: collapse;" append =style ;
: do-escaping ( string style -- string )
html swap at [ chars>entities ] unless ;
html swap at [ escape-string ] unless ;
PRIVATE>
@ -151,13 +151,13 @@ M: html-stream stream-write1 ( char stream -- )
>r 1string r> stream-write ;
M: html-stream stream-write ( str stream -- )
>r chars>entities r> delegate stream-write ;
>r escape-string r> delegate stream-write ;
M: html-stream make-span-stream ( style stream -- stream' )
html-span-stream <html-sub-stream> ;
M: html-stream stream-format ( str style stream -- )
>r html over at [ >r chars>entities r> ] unless r>
>r html over at [ >r escape-string r> ] unless r>
format-html-span ;
M: html-stream make-block-stream ( style stream -- stream' )

8
extra/math/algebra/algebra-docs.factor
View File

@ -1,14 +1,6 @@
USING: help.markup help.syntax ;
IN: math.algebra
HELP: ext-euclidian
{ $values { "a" "a positive integer" } { "b" "a positive integer" } { "gcd" "a positive integer" } { "u" "an integer" } { "v" "an integer" } }
{ $description "Compute the greatest common divisor " { $snippet "gcd" } " of integers " { $snippet "a" } " and " { $snippet "b" } " using the extended Euclidian algorithm. In addition, this word also computes two other values " { $snippet "u" } " and " { $snippet "v" } " such that " { $snippet "a*u + b*v = gcd" } "." } ;
HELP: ring-inverse
{ $values { "a" "a positive integer" } { "b" "a positive integer" } { "i" "a positive integer" } }
{ $description "If " { $snippet "a" } " and " { $snippet "b" } " are coprime, " { $snippet "i" } " is the smallest positive integer such as " { $snippet "a*i = 1" } " in ring " { $snippet "Z/bZ" } "." } ;
HELP: chinese-remainder
{ $values { "aseq" "a sequence of integers" } { "nseq" "a sequence of positive integers" } { "x" "an integer" } }
{ $description "If " { $snippet "nseq" } " integers are pairwise coprimes, " { $snippet "x" } " is the smallest positive integer congruent to each element in " { $snippet "aseq" } " modulo the corresponding element in " { $snippet "nseq" } "." } ;

2
extra/math/algebra/algebra-tests.factor
View File

@ -1,5 +1,3 @@
USING: math.algebra tools.test ;
{ 2 5 -2 } [ 10 24 ext-euclidian ] unit-test
{ 17 } [ 19 23 ring-inverse ] unit-test
{ 11 } [ { 2 3 1 } { 3 4 5 } chinese-remainder ] unit-test

33
extra/math/algebra/algebra.factor
View File

@ -1,37 +1,8 @@
! Copyright (c) 2007 Samuel Tardieu
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.ranges namespaces sequences vars ;
USING: kernel math math.functions sequences ;
IN: math.algebra
<PRIVATE
! The traditional name for the first variable is "r", but we want to avoid
! a redefinition of "r>" and ">r", so we chose to use "s" instead.
VARS: s-1 u-1 v-1 s u v ;
: init ( a b -- )
>s >s-1 0 >u 1 >u-1 1 >v 0 >v-1 ;
: advance ( r u v -- )
v> >v-1 >v u> >u-1 >u s> >s-1 >s ; inline
: step ( -- )
s-1> s> 2dup /mod drop [ * - ] keep u-1> over u> * - v-1> rot v> * -
advance ;
PRIVATE>
! Extended Euclidian: http://en.wikipedia.org/wiki/Extended_Euclidean_algorithm
: ext-euclidian ( a b -- gcd u v )
[ init [ s> 0 > ] [ step ] [ ] while s-1> u-1> v-1> ] with-scope ; foldable
! Inverse a in ring Z/bZ
: ring-inverse ( a b -- i )
[ ext-euclidian drop nip ] keep rem ; foldable
! Chinese remainder: http://en.wikipedia.org/wiki/Chinese_remainder_theorem
: chinese-remainder ( aseq nseq -- x )
dup product
[ [ over / [ ext-euclidian ] keep * 2nip * ] curry 2map sum ] keep rem ;
foldable
[ [ over / [ swap gcd drop ] keep * * ] curry 2map sum ] keep rem ; foldable

4
extra/project-euler/134/134.factor
View File

@ -34,9 +34,9 @@ IN: project-euler.134
over 0 2array rot next-power-of-10 rot 2array chinese-remainder ;
: euler134 ( -- answer )
5 lprimes-from [ 1000000 > ] luntil [ [ s + ] keep ] leach drop ;
0 5 lprimes-from uncons [ 1000000 > ] luntil [ [ s + ] keep ] leach drop ;
! [ euler134 ] 10 ave-time
! 6743 ms run / 79 ms GC ave time - 10 trials
! 3797 ms run / 30 ms GC ave time - 10 trials
MAIN: euler134

12
extra/project-euler/ave-time/ave-time.factor
View File

@ -1,23 +1,21 @@
! Copyright (c) 2007 Aaron Schaefer
! See http://factorcode.org/license.txt for BSD license.
USING: arrays effects inference io kernel math math.functions math.parser
USING: arrays combinators io kernel math math.functions math.parser
math.statistics namespaces sequences tools.time ;
IN: project-euler.ave-time
<PRIVATE
: clean-stack ( quot -- )
infer dup effect-out swap effect-in - [ drop ] times ;
: ave-benchmarks ( seq -- pair )
flip [ mean round ] map ;
PRIVATE>
: collect-benchmarks ( quot n -- seq )
[
1- [ [ benchmark ] keep -rot 2array , [ clean-stack ] keep ] times
] curry { } make >r benchmark 2array r> swap add ; inline
[
>r >r datastack r> [ benchmark 2array , ] curry tuck
[ with-datastack drop ] 2curry r> swap times call
] { } make ;
: ave-time ( quot n -- )
[ collect-benchmarks ] keep swap ave-benchmarks [

25
extra/project-euler/project-euler.factor
View File

@ -1,11 +1,14 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: io io.files kernel math.parser namespaces sequences strings
vocabs vocabs.loader system project-euler.ave-time
USING: definitions io io.files kernel math.parser sequences strings
vocabs vocabs.loader
project-euler.001 project-euler.002 project-euler.003 project-euler.004
project-euler.005 project-euler.006 project-euler.007 project-euler.008
project-euler.009 project-euler.010 project-euler.011 project-euler.012
project-euler.013 project-euler.014 project-euler.015 project-euler.016 ;
project-euler.013 project-euler.014 project-euler.015 project-euler.016
project-euler.017 project-euler.018 project-euler.019
project-euler.067
project-euler.134 ;
IN: project-euler
<PRIVATE
@ -15,22 +18,16 @@ IN: project-euler
print readln string>number ;
: number>euler ( n -- str )
number>string string>digits 3 0 pad-left [ number>string ] map concat ;
number>string 3 CHAR: 0 pad-left ;
: solution-path ( n -- str )
number>euler dup [
"project-euler" vocab-root ?resource-path %
os "windows" = [
"\\project-euler\\" % % "\\" % % ".factor" %
] [
"/project-euler/" % % "/" % % ".factor" %
] if
] "" make ;
: solution-path ( n -- str/f )
number>euler "project-euler." swap append vocab where
dup [ first ?resource-path ] when ;
PRIVATE>
: problem-solved? ( n -- ? )
solution-path exists? ;
solution-path ;
: run-project-euler ( -- )
problem-prompt dup problem-solved? [

2
extra/shufflers/shufflers-tests.factor
View File

@ -1,7 +1,5 @@
USING: shufflers tools.test ;
[ { 1 1 0 0 1 0 } ] [ BIN: 010011 2 6 translate ] unit-test
SHUFFLE: abcd 4
[ ] [ 1 2 3 4 abcd- ] unit-test
[ 1 2 1 2 ] [ 1 2 3 abc-abab ] unit-test

2
extra/xml/test/templating.factor
View File

@ -40,4 +40,4 @@ M: object (r-ref) drop ;
sample-doc string>xml dup template xml>string
] with-scope ;
[ "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?><html xmlns:f=\"http://littledan.onigirihouse.com/namespaces/replace\"><body><span f:sub=\"foo\">foo</span><div f:sub=\"bar\">blah<a/></div><p f:sub=\"baz\"/></body></html>" ] [ test-refs ] unit-test
[ "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?>\n<html xmlns:f=\"http://littledan.onigirihouse.com/namespaces/replace\"><body><span f:sub=\"foo\">foo</span><div f:sub=\"bar\">blah<a/></div><p f:sub=\"baz\"/></body></html>" ] [ test-refs ] unit-test

6
extra/xml/test/test.factor
View File

@ -26,7 +26,7 @@ SYMBOL: xml-file
] unit-test
[ V{ "fa&g" } ] [ xml-file get "x" get-id tag-children ] unit-test
[ "that" ] [ xml-file get "this" swap at ] unit-test
[ "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?><a b=\"c\"/>" ]
[ "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?>\n<a b=\"c\"/>" ]
[ "<a b='c'/>" string>xml xml>string ] unit-test
[ "abcd" ] [
"<main>a<sub>bc</sub>d<nothing/></main>" string>xml
@ -44,5 +44,7 @@ SYMBOL: xml-file
at swap "z" >r tuck r> swap set-at
T{ name f "blah" "z" f } swap at ] unit-test
[ "foo" ] [ "<boo><![CDATA[foo]]></boo>" string>xml children>string ] unit-test
[ "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?><foo>bar baz</foo>" ]
[ "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?>\n<foo>bar baz</foo>" ]
[ "<foo>bar</foo>" string>xml [ " baz" append ] map xml>string ] unit-test
[ "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?>\n<foo>\n bar\n</foo>" ]
[ "<foo> bar </foo>" string>xml pprint-xml>string ] unit-test

99
extra/xml/writer/writer.factor
View File

@ -4,18 +4,60 @@ USING: hashtables kernel math namespaces sequences strings
io io.streams.string xml.data assocs ;
IN: xml.writer
: write-entities
SYMBOL: xml-pprint?
SYMBOL: sensitive-tags
SYMBOL: indentation
SYMBOL: indenter
" " indenter set-global
: sensitive? ( tag -- ? )
sensitive-tags get swap [ names-match? ] curry contains? ;
: ?indent ( -- )
xml-pprint? get [
nl indentation get indenter get <repetition> [ write ] each
] when ;
: indent ( -- )
xml-pprint? get [ 1 indentation +@ ] when ;
: unindent ( -- )
xml-pprint? get [ -1 indentation +@ ] when ;
: trim-whitespace ( string -- no-whitespace )
[ [ blank? not ] find drop 0 or ] keep
[ [ blank? not ] find-last drop [ 1+ ] [ 0 ] if* ] keep
subseq ;
: ?filter-children ( children -- no-whitespace )
xml-pprint? get [
[ dup string? [ trim-whitespace ] when ] map
[ dup empty? swap string? and not ] subset
] when ;
: entities-out
H{
{ CHAR: < "&lt;" }
{ CHAR: > "&gt;" }
{ CHAR: & "&amp;" }
} ;
: quoted-entities-out
H{
{ CHAR: & "&amp;" }
{ CHAR: ' "&apos;" }
{ CHAR: " "&quot;" }
} ;
: chars>entities ( str -- str )
: escape-string-by ( str table -- escaped )
#! Convert <, >, &, ' and " to HTML entities.
[ [ dup write-entities at [ % ] [ , ] ?if ] each ] "" make ;
[ [ dupd at [ % ] [ , ] ?if ] curry each ] "" make ;
: escape-string ( str -- newstr )
entities-out escape-string-by ;
: escape-quoted-string ( str -- newstr )
quoted-entities-out escape-string-by ;
: print-name ( name -- )
dup name-space f like
@ -27,27 +69,35 @@ IN: xml.writer
" " write
swap print-name
"=\"" write
chars>entities write
escape-quoted-string write
"\"" write
] assoc-each ;
GENERIC: write-item ( object -- )
M: string write-item
chars>entities write ;
escape-string write ;
: write-tag ( tag -- )
CHAR: < write1
dup print-name tag-attrs print-attrs ;
M: contained-tag write-item
CHAR: < write1
dup print-name tag-attrs print-attrs
"/>" write ;
write-tag "/>" write ;
: write-children ( tag -- )
indent tag-children ?filter-children
[ ?indent write-item ] each unindent ;
: write-end-tag ( tag -- )
?indent "</" write print-name CHAR: > write1 ;
M: open-tag write-item
CHAR: < write1
dup print-name
dup tag-attrs print-attrs
CHAR: > write1
dup tag-children [ write-item ] each
"</" write print-name CHAR: > write1 ;
xml-pprint? [ [
over sensitive? not and xml-pprint? set
dup write-tag CHAR: > write1
dup write-children write-end-tag
] keep ] change ;
M: comment write-item
"<!--" write comment-text write "-->" write ;
@ -62,7 +112,7 @@ M: instruction write-item
"<?xml version=\"" write dup prolog-version write
"\" encoding=\"" write dup prolog-encoding write
prolog-standalone [ "\" standalone=\"yes" write ] when
"\"?>" write ;
"\"?>\n" write ;
: write-chunk ( seq -- )
[ write-item ] each ;
@ -79,3 +129,22 @@ M: instruction write-item
: xml>string ( xml -- string )
[ write-xml ] string-out ;
: with-xml-pprint ( sensitive-tags quot -- )
[
swap [ assure-name ] map sensitive-tags set
0 indentation set
xml-pprint? on
call
] with-scope ; inline
: pprint-xml-but ( xml sensitive-tags -- )
[ print-xml ] with-xml-pprint ;
: pprint-xml ( xml -- )
f pprint-xml-but ;
: pprint-xml>string-but ( xml sensitive-tags -- string )
[ xml>string ] with-xml-pprint ;
: pprint-xml>string ( xml -- string )
f pprint-xml>string-but ;

89
extra/xml/xml-docs.factor
View File

@ -7,14 +7,29 @@ strings sequences io ;
HELP: string>xml
{ $values { "string" "a string" } { "xml" "an xml document" } }
{ $description "converts a string into an " { $link xml }
" datatype for further processing" }
{ $see-also xml>string xml-reprint } ;
" datatype for further processing" } ;
HELP: read-xml
{ $values { "stream" "a stream that supports readln" }
{ "xml" "an XML document" } }
{ $description "exausts the given stream, reading an XML document from it" } ;
HELP: file>xml
{ $values { "filename" "a string representing a filename" }
{ "xml" "an XML document" } }
{ $description "opens the given file, reads it in as XML, closes the file and returns the corresponding XML tree" } ;
{ string>xml read-xml file>xml } related-words
HELP: xml>string
{ $values { "xml" "an xml document" } { "string" "a string" } }
{ $description "converts an xml document (" { $link xml } ") into a string" }
{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" }
{ $see-also string>xml xml-reprint write-xml } ;
{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ;
HELP: pprint-xml>string
{ $values { "xml" "an xml document" } { "string" "a string" } }
{ $description "converts an xml document (" { $link xml } ") into a string in a prettyprinted form." }
{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ;
HELP: xml-parse-error
{ $class-description "the exception class that all parsing errors in XML documents are in." } ;
@ -22,20 +37,34 @@ HELP: xml-parse-error
HELP: xml-reprint
{ $values { "string" "a string of XML" } }
{ $description "parses XML and prints it out again, for testing purposes" }
{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" }
{ $see-also write-xml xml>string string>xml } ;
{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ;
HELP: write-xml
{ $values { "xml" "an XML document" } }
{ $description "prints the contents of an XML document (" { $link xml } ") to stdio" }
{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" }
{ $see-also xml>string xml-reprint read-xml } ;
{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ;
HELP: read-xml
{ $values { "stream" "a stream that supports readln" }
{ "xml" "an XML document" } }
{ $description "exausts the given stream, reading an XML document from it" }
{ $see-also write-xml string>xml } ;
HELP: print-xml
{ $values { "xml" "an XML document" } }
{ $description "prints the contents of an XML document (" { $link xml } ") to stdio, followed by a newline" }
{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ;
HELP: pprint-xml
{ $values { "xml" "an XML document" } }
{ $description "prints the contents of an XML document (" { $link xml } ") to stdio in a prettyprinted form." }
{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ;
HELP: pprint-xml-but
{ $values { "xml" "an XML document" } { "sensitive-tags" "a sequence of names" } }
{ $description "Prettyprints an XML document, leaving the whitespace of the tags with names in sensitive-tags intact." }
{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ;
HELP: pprint-xml>string-but
{ $values { "xml" "an XML document" } { "sensitive-tags" "a sequence of names" } { "string" string } }
{ $description "Prettyprints an XML document, returning the result as a string and leaving the whitespace of the tags with names in sensitive-tags intact." }
{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ;
{ xml>string print-xml write-xml pprint-xml xml-reprint pprint-xml>string pprint-xml>string-but pprint-xml-but } related-words
HELP: PROCESS:
{ $syntax "PROCESS: word" }
@ -318,26 +347,27 @@ HELP: with-html-entities
{ $description "calls the given quotation using HTML entity values" }
{ $see-also html-entities with-entities } ;
HELP: file>xml
{ $values { "filename" "a string representing a filename" }
{ "xml" "an XML document" } }
{ $description "opens the given file, reads it in as XML, closes the file and returns the corresponding XML tree" }
{ $see-also string>xml read-xml } ;
ARTICLE: { "xml" "basic" } "Basic words for XML processing"
"These are the most basic words needed for processing an XML document"
$nl
"Parsing XML:"
ARTICLE: { "xml" "reading" } "Reading XML"
"The following words are used to read something into an XML document"
{ $subsection string>xml }
{ $subsection read-xml }
{ $subsection xml-chunk }
{ $subsection file>xml }
"Printing XML"
{ $subsection xml>string }
{ $subsection write-xml }
{ $subsection file>xml } ;
ARTICLE: { "xml" "writing" } "Writing XML"
"These words are used in implementing prettyprint"
{ $subsection write-item }
{ $subsection write-chunk }
"Other"
"These words are used to print XML normally"
{ $subsection xml>string }
{ $subsection write-xml }
{ $subsection print-xml }
"These words are used to prettyprint XML"
{ $subsection pprint-xml>string }
{ $subsection pprint-xml>string-but }
{ $subsection pprint-xml }
{ $subsection pprint-xml-but }
"This word reads and writes XML"
{ $subsection xml-reprint } ;
ARTICLE: { "xml" "classes" } "XML data classes"
@ -433,7 +463,8 @@ ARTICLE: { "xml" "intro" } "XML"
"The XML module attempts to implement the XML 1.1 standard, converting strings of text into XML and vice versa. It currently is a work in progress."
$nl
"The XML module was implemented by Daniel Ehrenberg, with contributions from the Factor community"
{ $subsection { "xml" "basic" } }
{ $subsection { "xml" "reading" } }
{ $subsection { "xml" "writing" } }
{ $subsection { "xml" "classes" } }
{ $subsection { "xml" "construct" } }
{ $subsection { "xml" "utils" } }