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

Merge branch 'master' of git://factorcode.org/git/factor into unicode 

Conflicts:

	extra/io/encodings/ascii/ascii.factor
	extra/io/encodings/latin1/latin1.factor
db4
Daniel Ehrenberg 2008-03-09 22:04:19 -05:00
parent 191a61a024 57c772303f
commit 862dd0b5cb
127 changed files with 1793 additions and 765 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
core/alien/c-types/c-types-docs.factor
View File

@ -88,29 +88,11 @@ HELP: memory>byte-array ( base len -- string )
{ $values { "base" c-ptr } { "len" "a non-negative integer" } { "byte-array" byte-array } }
{ $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new byte array." } ;
HELP: memory>char-string ( base len -- string )
{ $values { "base" c-ptr } { "len" "a non-negative integer" } { "string" string } }
{ $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new string." } ;
HELP: memory>u16-string ( base len -- string )
{ $values { "base" c-ptr } { "len" "a non-negative integer" } { "string" string } }
{ $description "Reads " { $snippet "len" } " UCS2 characters starting from " { $snippet "base" } " and stores them in a new string." } ;
HELP: byte-array>memory ( string base -- )
{ $values { "byte-array" byte-array } { "base" c-ptr } }
{ $description "Writes a byte array to memory starting from the " { $snippet "base" } " address." }
{ $warning "This word is unsafe. Improper use can corrupt memory." } ;
HELP: string>char-memory ( string base -- )
{ $values { "string" string } { "base" c-ptr } }
{ $description "Writes a string to memory starting from the " { $snippet "base" } " address." }
{ $warning "This word is unsafe. Improper use can corrupt memory." } ;
HELP: string>u16-memory ( string base -- )
{ $values { "string" string } { "base" c-ptr } }
{ $description "Writes a string to memory starting from the " { $snippet "base" } " address." }
{ $warning "This word is unsafe. Improper use can corrupt memory." } ;
HELP: malloc-array
{ $values { "n" "a non-negative integer" } { "type" "a C type" } { "alien" alien } }
{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type." }
@ -293,11 +275,7 @@ ARTICLE: "c-strings" "C strings"
$nl
"Finally, a set of words can be used to read and write " { $snippet "char*" } " and " { $snippet "ushort*" } " strings at arbitrary addresses:"
{ $subsection alien>char-string }
{ $subsection alien>u16-string }
{ $subsection memory>char-string }
{ $subsection memory>u16-string }
{ $subsection string>char-memory }
{ $subsection string>u16-memory } ;
{ $subsection alien>u16-string } ;
ARTICLE: "c-data" "Passing data between Factor and C"
"Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers. Also Factor's garbage collector can move objects in memory, which means that special support has to be provided for passing blocks of memory to C code."

13
core/alien/c-types/c-types.factor
View File

@ -155,20 +155,9 @@ M: float-array byte-length length "double" heap-size * ;
: memory>byte-array ( alien len -- byte-array )
dup <byte-array> [ -rot memcpy ] keep ;
: memory>char-string ( alien len -- string )
memory>byte-array >string ;
DEFER: c-ushort-array>
: memory>u16-string ( alien len -- string )
[ memory>byte-array ] keep 2/ c-ushort-array> >string ;
: byte-array>memory ( byte-array base -- )
swap dup length memcpy ;
: string>char-memory ( string base -- )
>r B{ } like r> byte-array>memory ;
DEFER: >c-ushort-array
: string>u16-memory ( string base -- )
@ -274,7 +263,7 @@ M: long-long-type box-return ( type -- )
] when ;
: malloc-file-contents ( path -- alien )
binary file-contents >byte-array malloc-byte-array ;
binary file-contents malloc-byte-array ;
[
[ alien-cell ]

8
core/io/binary/binary-tests.factor
View File

@ -1,8 +1,10 @@
USING: io.binary tools.test ;
USING: io.binary tools.test classes math ;
IN: io.binary.tests
[ "\0\0\u000004\u0000d2" ] [ 1234 4 >be ] unit-test
[ "\u0000d2\u000004\0\0" ] [ 1234 4 >le ] unit-test
[ B{ 0 0 4 HEX: d2 } ] [ 1234 4 >be ] unit-test
[ B{ HEX: d2 4 0 0 } ] [ 1234 4 >le ] unit-test
[ 1234 ] [ 1234 4 >be be> ] unit-test
[ 1234 ] [ 1234 4 >le le> ] unit-test
[ fixnum ] [ B{ 0 0 0 0 0 0 0 0 0 0 } be> class ] unit-test

2
core/io/binary/binary.factor
View File

@ -3,7 +3,7 @@
USING: kernel math sequences ;
IN: io.binary
: le> ( seq -- x ) B{ } like byte-array>bignum ;
: le> ( seq -- x ) B{ } like byte-array>bignum >integer ;
: be> ( seq -- x ) <reversed> le> ;
: mask-byte ( x -- y ) HEX: ff bitand ; inline

3
core/io/encodings/utf8/utf8-tests.factor Normal file → Executable file
View File

@ -1,4 +1,5 @@
USING: io.encodings.utf8 tools.test io.encodings.string strings arrays ;
USING: io.encodings.utf8 tools.test io.encodings.string strings arrays unicode ;
IN: io.encodings.utf8.tests
: decode-utf8-w/stream ( array -- newarray )
utf8 decode >array ;

12
core/io/files/files-tests.factor
View File

@ -6,9 +6,8 @@ USING: tools.test io.files io threads kernel continuations io.encodings.ascii ;
[ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test
[ ] [
"test-foo.txt" temp-file ascii [
"Hello world." print
] with-file-writer
{ "Hello world." }
"test-foo.txt" temp-file ascii set-file-lines
] unit-test
[ ] [
@ -69,8 +68,8 @@ USING: tools.test io.files io threads kernel continuations io.encodings.ascii ;
[ ] [ "delete-tree-test/a/b/c" temp-file make-directories ] unit-test
[ ] [
"delete-tree-test/a/b/c/d" temp-file
ascii [ "Hi" print ] with-file-writer
{ "Hi" }
"delete-tree-test/a/b/c/d" temp-file ascii set-file-lines
] unit-test
[ ] [
@ -82,8 +81,9 @@ USING: tools.test io.files io threads kernel continuations io.encodings.ascii ;
] unit-test
[ ] [
"Foobar"
"copy-tree-test/a/b/c/d" temp-file
ascii [ "Foobar" write ] with-file-writer
ascii set-file-contents
] unit-test
[ ] [

16
core/io/files/files.factor
View File

@ -213,18 +213,24 @@ C: <pathname> pathname
M: pathname <=> [ pathname-string ] compare ;
: file-lines ( path encoding -- seq ) <file-reader> lines ;
: file-contents ( path encoding -- str )
dupd <file-reader> swap file-length <sbuf>
[ stream-copy ] keep >string ;
: file-lines ( path encoding -- seq )
<file-reader> lines ;
: with-file-reader ( path encoding quot -- )
>r <file-reader> r> with-stream ; inline
: file-contents ( path encoding -- str )
dupd [ file-length read ] with-file-reader ;
: with-file-writer ( path encoding quot -- )
>r <file-writer> r> with-stream ; inline
: set-file-lines ( seq path encoding -- )
[ [ print ] each ] with-file-writer ;
: set-file-contents ( str path encoding -- )
[ write ] with-file-writer ;
: with-file-appender ( path encoding quot -- )
>r <file-appender> r> with-stream ; inline

4
core/io/streams/c/c-tests.factor
View File

@ -3,9 +3,7 @@ io.encodings.ascii strings ;
IN: io.streams.c.tests
[ "hello world" ] [
"test.txt" temp-file ascii [
"hello world" write
] with-file-writer
"hello world" "test.txt" temp-file ascii set-file-contents
"test.txt" temp-file "rb" fopen <c-reader> contents
>string

4
core/layouts/layouts.factor
View File

@ -33,6 +33,10 @@ SYMBOL: type-numbers
: most-negative-fixnum ( -- n )
first-bignum neg ;
M: bignum >integer
dup most-negative-fixnum most-positive-fixnum between?
[ >fixnum ] when ;
M: real >integer
dup most-negative-fixnum most-positive-fixnum between?
[ >fixnum ] [ >bignum ] if ;

22
core/listener/listener-tests.factor
View File

@ -8,9 +8,11 @@ IN: listener.tests
: parse-interactive ( string -- quot )
<string-reader> stream-read-quot ;
[ [ ] ] [
"USE: listener.tests hello" parse-interactive
] unit-test
[
[ [ ] ] [
"USE: listener.tests hello" parse-interactive
] unit-test
] with-file-vocabs
[
"debugger" use+
@ -35,8 +37,10 @@ IN: listener.tests
] unit-test
[
"USE: vocabs.loader.test.c" parse-interactive
] must-fail
[
"USE: vocabs.loader.test.c" parse-interactive
] must-fail
] with-file-vocabs
[ ] [
[
@ -44,7 +48,9 @@ IN: listener.tests
] with-compilation-unit
] unit-test
[ ] [
"IN: listener.tests : hello\n\"world\" ;" parse-interactive
[
[ ] [
"IN: listener.tests : hello\n\"world\" ;" parse-interactive
drop
] unit-test
] unit-test
] with-file-vocabs

2
core/math/integers/integers.factor
View File

@ -6,10 +6,10 @@ IN: math.integers.private
M: integer numerator ;
M: integer denominator drop 1 ;
M: integer >integer ;
M: fixnum >fixnum ;
M: fixnum >bignum fixnum>bignum ;
M: fixnum >integer ;
M: fixnum number= eq? ;

109
core/math/intervals/intervals-tests.factor
View File

@ -1,5 +1,5 @@
USING: math.intervals kernel sequences words math arrays
prettyprint tools.test random vocabs ;
prettyprint tools.test random vocabs combinators ;
IN: math.intervals.tests
[ T{ interval f { 1 t } { 2 t } } ] [ 1 2 [a,b] ] unit-test
@ -94,33 +94,88 @@ IN: math.intervals.tests
] unit-test
] when
[ t ] [ 0 5 [a,b] 5 interval<= ] unit-test
[ t ] [ 1 [a,a] interval-singleton? ] unit-test
[ incomparable ] [ 0 5 [a,b] 5 interval< ] unit-test
[ f ] [ 1 1 [a,b) interval-singleton? ] unit-test
[ t ] [ 0 5 [a,b) 5 interval< ] unit-test
[ f ] [ 1 3 [a,b) interval-singleton? ] unit-test
[ f ] [ 0 5 [a,b] -1 interval< ] unit-test
[ f ] [ 1 1 (a,b) interval-singleton? ] unit-test
[ incomparable ] [ 0 5 [a,b] 1 interval< ] unit-test
[ 2 ] [ 1 3 [a,b) interval-length ] unit-test
[ t ] [ -1 1 (a,b) -1 interval> ] unit-test
[ 0 ] [ f interval-length ] unit-test
[ t ] [ -1 1 (a,b) -1 interval>= ] unit-test
[ t ] [ 0 5 [a,b] 5 [a,a] interval<= ] unit-test
[ f ] [ -1 1 (a,b) -1 interval< ] unit-test
[ incomparable ] [ 0 5 [a,b] 5 [a,a] interval< ] unit-test
[ f ] [ -1 1 (a,b) -1 interval<= ] unit-test
[ t ] [ 0 5 [a,b) 5 [a,a] interval< ] unit-test
[ t ] [ -1 1 (a,b] 1 interval<= ] unit-test
[ f ] [ 0 5 [a,b] -1 [a,a] interval< ] unit-test
[ incomparable ] [ 0 5 [a,b] 1 [a,a] interval< ] unit-test
[ t ] [ -1 1 (a,b) -1 [a,a] interval> ] unit-test
[ t ] [ -1 1 (a,b) -1 [a,a] interval>= ] unit-test
[ f ] [ -1 1 (a,b) -1 [a,a] interval< ] unit-test
[ f ] [ -1 1 (a,b) -1 [a,a] interval<= ] unit-test
[ t ] [ -1 1 (a,b] 1 [a,a] interval<= ] unit-test
[ t ] [ -1 1 (a,b] 1 2 [a,b] interval<= ] unit-test
[ incomparable ] [ -1 1 (a,b] 1 2 [a,b] interval>= ] unit-test
[ incomparable ] [ -1 1 (a,b] 1 2 [a,b] interval> ] unit-test
[ t ] [ -1 1 (a,b] 1 2 (a,b] interval<= ] unit-test
[ f ] [ 0 10 [a,b] 0 [a,a] interval< ] unit-test
[ f ] [ 0 10 [a,b] 10 [a,a] interval> ] unit-test
[ incomparable ] [ 0 [a,a] 0 10 [a,b] interval< ] unit-test
[ incomparable ] [ 10 [a,a] 0 10 [a,b] interval> ] unit-test
[ t ] [ 0 [a,a] 0 10 [a,b] interval<= ] unit-test
[ incomparable ] [ 0 [a,a] 0 10 [a,b] interval>= ] unit-test
[ t ] [ 0 10 [a,b] 0 [a,a] interval>= ] unit-test
[ t ] [
418
418 423 [a,b)
79 893 (a,b]
interval-max
interval-contains?
] unit-test
[ f ] [ 1 100 [a,b] -1 1 [a,b] interval/i ] unit-test
! Interval random tester
: random-element ( interval -- n )
dup interval-to first swap interval-from first tuck -
random + ;
dup interval-to first over interval-from first tuck - random +
2dup swap interval-contains? [
nip
] [
drop random-element
] if ;
: random-interval ( -- interval )
1000 random dup 1 1000 random + + [a,b] ;
1000 random dup 2 1000 random + +
1 random zero? [ [ neg ] 2apply swap ] when
4 random {
{ 0 [ [a,b] ] }
{ 1 [ [a,b) ] }
{ 2 [ (a,b) ] }
{ 3 [ (a,b] ] }
} case ;
: random-op
{
@ -138,12 +193,32 @@ IN: math.intervals.tests
random ;
: interval-test
random-interval random-interval random-op
random-interval random-interval random-op ! 3dup . . .
0 pick interval-contains? over first { / /i } member? and [
3drop t
] [
[ >r [ random-element ] 2apply r> first execute ] 3keep
[ >r [ random-element ] 2apply ! 2dup . .
r> first execute ] 3keep
second execute interval-contains?
] if ;
[ t ] [ 1000 [ drop interval-test ] all? ] unit-test
[ t ] [ 40000 [ drop interval-test ] all? ] unit-test
: random-comparison
{
{ < interval< }
{ <= interval<= }
{ > interval> }
{ >= interval>= }
} random ;
: comparison-test
random-interval random-interval random-comparison
[ >r [ random-element ] 2apply r> first execute ] 3keep
second execute dup incomparable eq? [
2drop t
] [
=
] if ;
[ t ] [ 40000 [ drop comparison-test ] all? ] unit-test

101
core/math/intervals/intervals.factor Normal file → Executable file
View File

@ -88,20 +88,6 @@ C: <interval> interval
[ interval>points [ first integer? ] both? ] both?
r> [ 2drop f ] if ; inline
: interval-shift ( i1 i2 -- i3 )
[ [ shift ] interval-op ] interval-integer-op ;
: interval-shift-safe ( i1 i2 -- i3 )
dup interval-to first 100 > [
2drop f
] [
interval-shift
] if ;
: interval-max ( i1 i2 -- i3 ) [ max ] interval-op ;
: interval-min ( i1 i2 -- i3 ) [ min ] interval-op ;
: interval-1+ ( i1 -- i2 ) 1 [a,a] interval+ ;
: interval-1- ( i1 -- i2 ) -1 [a,a] interval+ ;
@ -143,8 +129,41 @@ C: <interval> interval
: interval-contains? ( x int -- ? )
>r [a,a] r> interval-subset? ;
: interval-singleton? ( int -- ? )
interval>points
2dup [ second ] 2apply and
[ [ first ] 2apply = ]
[ 2drop f ] if ;
: interval-length ( int -- n )
dup
[ interval>points [ first ] 2apply swap - ]
[ drop 0 ] if ;
: interval-closure ( i1 -- i2 )
interval>points [ first ] 2apply [a,b] ;
dup [ interval>points [ first ] 2apply [a,b] ] when ;
: interval-shift ( i1 i2 -- i3 )
#! Inaccurate; could be tighter
[ [ shift ] interval-op ] interval-integer-op interval-closure ;
: interval-shift-safe ( i1 i2 -- i3 )
dup interval-to first 100 > [
2drop f
] [
interval-shift
] if ;
: interval-max ( i1 i2 -- i3 )
#! Inaccurate; could be tighter
[ max ] interval-op interval-closure ;
: interval-min ( i1 i2 -- i3 )
#! Inaccurate; could be tighter
[ min ] interval-op interval-closure ;
: interval-interior ( i1 -- i2 )
interval>points [ first ] 2apply (a,b) ;
: interval-division-op ( i1 i2 quot -- i3 )
>r 0 over interval-closure interval-contains?
@ -156,7 +175,7 @@ C: <interval> interval
: interval/i ( i1 i2 -- i3 )
[
[ [ /i ] interval-op ] interval-integer-op
] interval-division-op ;
] interval-division-op interval-closure ;
: interval-recip ( i1 -- i2 ) 1 [a,a] swap interval/ ;
@ -164,24 +183,46 @@ C: <interval> interval
SYMBOL: incomparable
: interval-compare ( int n quot -- ? )
>r dupd r> call interval-intersect dup [
= t incomparable ?
] [
2drop f
] if ; inline
: left-endpoint-< ( i1 i2 -- ? )
[ swap interval-subset? ] 2keep
[ nip interval-singleton? ] 2keep
[ interval-from ] 2apply =
and and ;
: interval< ( int n -- ? )
[ [-inf,a) ] interval-compare ; inline
: right-endpoint-< ( i1 i2 -- ? )
[ interval-subset? ] 2keep
[ drop interval-singleton? ] 2keep
[ interval-to ] 2apply =
and and ;
: interval<= ( int n -- ? )
[ [-inf,a] ] interval-compare ; inline
: (interval<) over interval-from over interval-from endpoint< ;
: interval> ( int n -- ? )
[ (a,inf] ] interval-compare ; inline
: interval< ( i1 i2 -- ? )
{
{ [ 2dup interval-intersect not ] [ (interval<) ] }
{ [ 2dup left-endpoint-< ] [ f ] }
{ [ 2dup right-endpoint-< ] [ f ] }
{ [ t ] [ incomparable ] }
} cond 2nip ;
: interval>= ( int n -- ? )
[ [a,inf] ] interval-compare ; inline
: left-endpoint-<= ( i1 i2 -- ? )
>r interval-from r> interval-to = ;
: right-endpoint-<= ( i1 i2 -- ? )
>r interval-to r> interval-from = ;
: interval<= ( i1 i2 -- ? )
{
{ [ 2dup interval-intersect not ] [ (interval<) ] }
{ [ 2dup right-endpoint-<= ] [ t ] }
{ [ t ] [ incomparable ] }
} cond 2nip ;
: interval> ( i1 i2 -- ? )
swap interval< ;
: interval>= ( i1 i2 -- ? )
swap interval<= ;
: assume< ( i1 i2 -- i3 )
interval-to first [-inf,a) interval-intersect ;

10
core/optimizer/math/math.factor
View File

@ -371,13 +371,15 @@ most-negative-fixnum most-positive-fixnum [a,b]
] assoc-each
! Remove redundant comparisons
: known-comparison? ( #call -- ? )
: intervals-first2 ( #call -- first second )
dup dup node-in-d first node-interval
swap dup node-in-d second node-literal real? and ;
swap dup node-in-d second node-interval ;
: known-comparison? ( #call -- ? )
intervals-first2 and ;
: perform-comparison ( #call word -- result )
>r dup dup node-in-d first node-interval
swap dup node-in-d second node-literal r> execute ; inline
>r intervals-first2 r> execute ; inline
: foldable-comparison? ( #call word -- ? )
>r dup known-comparison? [

7
core/parser/parser.factor
View File

@ -240,11 +240,14 @@ PREDICATE: unexpected unexpected-eof
: CREATE ( -- word ) scan create-in ;
: CREATE-CLASS ( -- word )
scan in get create
: create-class ( word vocab -- word )
create
dup save-class-location
dup predicate-word dup set-word save-location ;
: CREATE-CLASS ( -- word )
scan in get create-class ;
: word-restarts ( possibilities -- restarts )
natural-sort [
[ "Use the word " swap summary append ] keep

6
extra/benchmark/mandel/mandel.factor
View File

@ -1,6 +1,7 @@
IN: benchmark.mandel
USING: arrays io kernel math namespaces sequences strings sbufs
math.functions math.parser io.files colors.hsv io.encodings.binary ;
math.functions math.parser io.files colors.hsv
io.encodings.ascii ;
: max-color 360 ; inline
: zoom-fact 0.8 ; inline
@ -65,7 +66,6 @@ SYMBOL: cols
] with-scope ;
: mandel-main ( -- )
"mandel.ppm" temp-file
binary [ mandel write ] with-file-writer ;
mandel "mandel.ppm" temp-file ascii set-file-contents ;
MAIN: mandel-main

5
extra/benchmark/raytracer/raytracer.factor
View File

@ -3,7 +3,7 @@
USING: float-arrays compiler generic io io.files kernel math
math.functions math.vectors math.parser namespaces sequences
sequences.private words io.encodings.binary ;
sequences.private words io.encodings.ascii ;
IN: benchmark.raytracer
! parameters
@ -170,7 +170,6 @@ DEFER: create ( level c r -- scene )
] "" make ;
: raytracer-main
"raytracer.pnm" temp-file
binary [ run write ] with-file-writer ;
run "raytracer.pnm" temp-file ascii set-file-contents ;
MAIN: raytracer-main

1
extra/bitfields/bitfields-tests.factor Normal file → Executable file
View File

@ -1,4 +1,5 @@
USING: tools.test bitfields kernel ;
IN: bitfields.tests
SAFE-BITFIELD: foo bar:5 baz:10 111 bing:2 ;

13
extra/builder/test/test.factor
View File

@ -7,6 +7,7 @@ USING: kernel namespaces sequences assocs builder continuations
tools.browser
tools.test
io.encodings.utf8
combinators.cleave
bootstrap.stage2 benchmark builder.util ;
IN: builder.test
@ -14,8 +15,18 @@ IN: builder.test
: do-load ( -- )
try-everything keys "../load-everything-vocabs" utf8 [ . ] with-file-writer ;
! : do-tests ( -- )
! run-all-tests keys "../test-all-vocabs" utf8 [ . ] with-file-writer ;
: do-tests ( -- )
run-all-tests keys "../test-all-vocabs" utf8 [ . ] with-file-writer ;
run-all-tests
"../test-all-vocabs" utf8
[
[ keys . ]
[ test-failures. ]
bi
]
with-file-writer ;
: do-benchmarks ( -- )
run-benchmarks "../benchmarks" utf8 [ . ] with-file-writer ;

1
extra/calendar/calendar-tests.factor
View File

@ -1,5 +1,6 @@
USING: arrays calendar kernel math sequences tools.test
continuations system ;
IN: calendar.tests
[ f ] [ 2004 12 32 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2004 2 30 0 0 0 0 <timestamp> valid-timestamp? ] unit-test

4
extra/cocoa/plists/plists.factor
View File

@ -19,5 +19,5 @@ M: hashtable >plist
>plist 1array "plist" build-tag*
dup { { "version" "1.0" } } update ;
: print-plist ( obj -- )
build-plist build-xml print-xml ;
: plist>string ( obj -- string )
build-plist build-xml xml>string ;

15
extra/crypto/hmac/hmac-tests.factor
View File

@ -1,11 +1,12 @@
USING: kernel io strings sequences namespaces math parser crypto.hmac tools.test ;
USING: kernel io strings byte-arrays sequences namespaces math
parser crypto.hmac tools.test ;
IN: crypto.hmac.tests
[ "\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d" ] [ 16 11 <string> "Hi There" string>md5-hmac >string ] unit-test
[ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ] [ "Jefe" "what do ya want for nothing?" string>md5-hmac >string ] unit-test
[ "V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6" ] [ 16 HEX: aa <string> 50 HEX: dd <string> string>md5-hmac >string ] unit-test
[ "\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d" ] [ 16 11 <string> "Hi There" byte-array>md5-hmac >string ] unit-test
[ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ] [ "Jefe" "what do ya want for nothing?" byte-array>md5-hmac >string ] unit-test
[ "V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6" ] [ 16 HEX: aa <string> 50 HEX: dd <repetition> >byte-array byte-array>md5-hmac >string ] unit-test
[ "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9" ] [ 16 11 <string> "Hi There" string>sha1-hmac >string ] unit-test
[ "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y" ] [ "Jefe" "what do ya want for nothing?" string>sha1-hmac >string ] unit-test
[ "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb" ] [ 16 HEX: aa <string> 50 HEX: dd <string> string>sha1-hmac >string ] unit-test
[ "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9" ] [ 16 11 <string> "Hi There" >byte-array byte-array>sha1-hmac >string ] unit-test
[ "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y" ] [ "Jefe" "what do ya want for nothing?" >byte-array byte-array>sha1-hmac >string ] unit-test
[ "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb" ] [ 16 HEX: aa <string> 50 HEX: dd <repetition> >byte-array byte-array>sha1-hmac >string ] unit-test

11
extra/crypto/hmac/hmac.factor Normal file → Executable file
View File

@ -1,5 +1,5 @@
USING: arrays combinators crypto.common crypto.md5 crypto.sha1
crypto.md5.private io io.binary io.files io.streams.string
crypto.md5.private io io.binary io.files io.streams.byte-array
kernel math math.vectors memoize sequences io.encodings.binary ;
IN: crypto.hmac
@ -34,8 +34,8 @@ MEMO: opad ( -- seq ) 64 HEX: 5c <array> ;
: file>sha1-hmac ( K path -- hmac )
binary <file-reader> stream>sha1-hmac ;
: string>sha1-hmac ( K string -- hmac )
<string-reader> stream>sha1-hmac ;
: byte-array>sha1-hmac ( K string -- hmac )
binary <byte-reader> stream>sha1-hmac ;
: stream>md5-hmac ( K stream -- hmac )
@ -44,6 +44,5 @@ MEMO: opad ( -- seq ) 64 HEX: 5c <array> ;
: file>md5-hmac ( K path -- hmac )
binary <file-reader> stream>md5-hmac ;
: string>md5-hmac ( K string -- hmac )
<string-reader> stream>md5-hmac ;
: byte-array>md5-hmac ( K string -- hmac )
binary <byte-reader> stream>md5-hmac ;

10
extra/crypto/md5/md5-docs.factor Normal file → Executable file
View File

@ -1,15 +1,15 @@
USING: help.markup help.syntax kernel math sequences quotations
crypto.common ;
crypto.common byte-arrays ;
IN: crypto.md5
HELP: stream>md5
{ $values { "stream" "a stream" } { "byte-array" "md5 hash" } }
{ $description "Take the MD5 hash until end of stream." }
{ $notes "Used to implement " { $link string>md5 } " and " { $link file>md5 } ". Call " { $link hex-string } " to convert to the canonical string representation." } ;
{ $notes "Used to implement " { $link byte-array>md5 } " and " { $link file>md5 } ". Call " { $link hex-string } " to convert to the canonical string representation." } ;
HELP: string>md5
{ $values { "string" "a string" } { "byte-array" "byte-array md5 hash" } }
{ $description "Outputs the MD5 hash of a string." }
HELP: byte-array>md5
{ $values { "byte-array" byte-array } { "checksum" "an md5 hash" } }
{ $description "Outputs the MD5 hash of a byte array." }
{ $notes "Call " { $link hex-string } " to convert to the canonical string representation." } ;
HELP: file>md5

16
extra/crypto/md5/md5-tests.factor Normal file → Executable file
View File

@ -1,10 +1,10 @@
USING: kernel math namespaces crypto.md5 tools.test ;
USING: kernel math namespaces crypto.md5 tools.test byte-arrays ;
[ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" string>md5str ] unit-test
[ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" string>md5str ] unit-test
[ "900150983cd24fb0d6963f7d28e17f72" ] [ "abc" string>md5str ] unit-test
[ "f96b697d7cb7938d525a2f31aaf161d0" ] [ "message digest" string>md5str ] unit-test
[ "c3fcd3d76192e4007dfb496cca67e13b" ] [ "abcdefghijklmnopqrstuvwxyz" string>md5str ] unit-test
[ "d174ab98d277d9f5a5611c2c9f419d9f" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" string>md5str ] unit-test
[ "57edf4a22be3c955ac49da2e2107b67a" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" string>md5str ] unit-test
[ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" >byte-array byte-array>md5str ] unit-test
[ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" >byte-array byte-array>md5str ] unit-test
[ "900150983cd24fb0d6963f7d28e17f72" ] [ "abc" >byte-array byte-array>md5str ] unit-test
[ "f96b697d7cb7938d525a2f31aaf161d0" ] [ "message digest" >byte-array byte-array>md5str ] unit-test
[ "c3fcd3d76192e4007dfb496cca67e13b" ] [ "abcdefghijklmnopqrstuvwxyz" >byte-array byte-array>md5str ] unit-test
[ "d174ab98d277d9f5a5611c2c9f419d9f" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" >byte-array byte-array>md5str ] unit-test
[ "57edf4a22be3c955ac49da2e2107b67a" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" >byte-array byte-array>md5str ] unit-test

28
extra/crypto/md5/md5.factor Normal file → Executable file
View File

@ -1,21 +1,14 @@
! See http://www.faqs.org/rfcs/rfc1321.html
USING: kernel io io.binary io.files io.streams.string math
USING: kernel io io.binary io.files io.streams.byte-array math
math.functions math.parser namespaces splitting strings
sequences crypto.common byte-arrays locals sequences.private
io.encodings.binary ;
io.encodings.binary symbols ;
IN: crypto.md5
<PRIVATE
SYMBOL: a
SYMBOL: b
SYMBOL: c
SYMBOL: d
SYMBOL: old-a
SYMBOL: old-b
SYMBOL: old-c
SYMBOL: old-d
SYMBOLS: a b c d old-a old-b old-c old-d ;
: T ( N -- Y )
sin abs 4294967296 * >bignum ; foldable
@ -185,7 +178,14 @@ PRIVATE>
: stream>md5 ( stream -- byte-array )
[ initialize-md5 (stream>md5) get-md5 ] with-stream ;
: string>md5 ( string -- byte-array ) <string-reader> stream>md5 ;
: string>md5str ( string -- md5-string ) string>md5 hex-string ;
: file>md5 ( path -- byte-array ) binary <file-reader> stream>md5 ;
: file>md5str ( path -- md5-string ) file>md5 hex-string ;
: byte-array>md5 ( byte-array -- checksum )
binary <byte-reader> stream>md5 ;
: byte-array>md5str ( byte-array -- md5-string )
byte-array>md5 hex-string ;
: file>md5 ( path -- byte-array )
binary <file-reader> stream>md5 ;
: file>md5str ( path -- md5-string )
file>md5 hex-string ;

8
extra/crypto/sha1/sha1-tests.factor
View File

@ -1,14 +1,14 @@
USING: arrays kernel math namespaces sequences tools.test crypto.sha1 ;
[ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" string>sha1str ] unit-test
[ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" string>sha1str ] unit-test
[ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" byte-array>sha1str ] unit-test
[ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" byte-array>sha1str ] unit-test
! [ "34aa973cd4c4daa4f61eeb2bdbad27316534016f" ] [ 1000000 CHAR: a fill string>sha1str ] unit-test ! takes a long time...
[ "dea356a2cddd90c7a7ecedc5ebb563934f460452" ] [ "0123456701234567012345670123456701234567012345670123456701234567"
10 swap <array> concat string>sha1str ] unit-test
10 swap <array> concat byte-array>sha1str ] unit-test
[
";\u00009b\u0000fd\u0000cdK\u0000a3^s\u0000d0*\u0000e3\\\u0000b5\u000013<\u0000e8wA\u0000b2\u000083\u0000d20\u0000f1\u0000e6\u0000cc\u0000d8\u00001e\u00009c\u000004\u0000d7PT]\u0000ce,\u000001\u000012\u000080\u000096\u000099"
] [
"\u000066\u000053\u0000f1\u00000c\u00001a\u0000fa\u0000b5\u00004c\u000061\u0000c8\u000025\u000075\u0000a8\u00004a\u0000fe\u000030\u0000d8\u0000aa\u00001a\u00003a\u000096\u000096\u0000b3\u000018\u000099\u000092\u0000bf\u0000e1\u0000cb\u00007f\u0000a6\u0000a7"
string>sha1-interleave
byte-array>sha1-interleave
] unit-test

42
extra/crypto/sha1/sha1.factor Normal file → Executable file
View File

@ -1,23 +1,12 @@
USING: arrays combinators crypto.common kernel io io.encodings.binary
io.files io.streams.string math.vectors strings sequences
namespaces math parser sequences vectors io.binary
hashtables ;
USING: arrays combinators crypto.common kernel io
io.encodings.binary io.files io.streams.byte-array math.vectors
strings sequences namespaces math parser sequences vectors
io.binary hashtables symbols ;
IN: crypto.sha1
! Implemented according to RFC 3174.
SYMBOL: h0
SYMBOL: h1
SYMBOL: h2
SYMBOL: h3
SYMBOL: h4
SYMBOL: A
SYMBOL: B
SYMBOL: C
SYMBOL: D
SYMBOL: E
SYMBOL: w
SYMBOL: K
SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ;
: get-wth ( n -- wth ) w get nth ; inline
: shift-wth ( n -- x ) get-wth 1 bitroll-32 ; inline
@ -118,15 +107,22 @@ SYMBOL: K
[ [ h0 h1 h2 h3 h4 ] [ get 4 >be % ] each ] "" make ;
: stream>sha1 ( stream -- sha1 )
[ [ initialize-sha1 (stream>sha1) get-sha1 ] with-stream ] with-scope ;
[ initialize-sha1 (stream>sha1) get-sha1 ] with-stream ;
: string>sha1 ( string -- sha1 ) <string-reader> stream>sha1 ;
: string>sha1str ( string -- str ) string>sha1 hex-string ;
: string>sha1-bignum ( string -- n ) string>sha1 be> ;
: file>sha1 ( file -- sha1 ) binary <file-reader> stream>sha1 ;
: byte-array>sha1 ( string -- sha1 )
binary <byte-reader> stream>sha1 ;
: string>sha1-interleave ( string -- seq )
: byte-array>sha1str ( string -- str )
byte-array>sha1 hex-string ;
: byte-array>sha1-bignum ( string -- n )
byte-array>sha1 be> ;
: file>sha1 ( file -- sha1 )
binary <file-reader> stream>sha1 ;
: byte-array>sha1-interleave ( string -- seq )
[ zero? ] left-trim
dup length odd? [ 1 tail ] when
seq>2seq [ string>sha1 ] 2apply
seq>2seq [ byte-array>sha1 ] 2apply
swap 2seq>seq ;

12
extra/crypto/sha2/sha2-tests.factor Normal file → Executable file
View File

@ -1,7 +1,7 @@
USING: arrays kernel math namespaces sequences tools.test crypto.sha2 ;
[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ] [ "" string>sha-256-string ] unit-test
[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ] [ "abc" string>sha-256-string ] unit-test
[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ] [ "message digest" string>sha-256-string ] unit-test
[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ] [ "abcdefghijklmnopqrstuvwxyz" string>sha-256-string ] unit-test
[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" string>sha-256-string ] unit-test
[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" string>sha-256-string ] unit-test
[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ] [ "" byte-array>sha-256-string ] unit-test
[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ] [ "abc" byte-array>sha-256-string ] unit-test
[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ] [ "message digest" byte-array>sha-256-string ] unit-test
[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ] [ "abcdefghijklmnopqrstuvwxyz" byte-array>sha-256-string ] unit-test
[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" byte-array>sha-256-string ] unit-test
[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" byte-array>sha-256-string ] unit-test

30
extra/crypto/sha2/sha2.factor Normal file → Executable file
View File

@ -1,19 +1,10 @@
USING: crypto.common kernel splitting math sequences namespaces
io.binary ;
io.binary symbols ;
IN: crypto.sha2
<PRIVATE
SYMBOL: vars
SYMBOL: M
SYMBOL: K
SYMBOL: H
SYMBOL: S0
SYMBOL: S1
SYMBOL: process-M
SYMBOL: word-size
SYMBOL: block-size
SYMBOL: >word
SYMBOLS: vars M K H S0 S1 process-M word-size block-size >word ;
: a 0 ;
: b 1 ;
@ -117,26 +108,25 @@ SYMBOL: >word
T1 T2 update-vars
] with each vars get H get [ w+ ] 2map H set ;
: seq>string ( n seq -- string )
[ swap [ >be % ] curry each ] "" make ;
: seq>byte-array ( n seq -- string )
[ swap [ >be % ] curry each ] B{ } make ;
: string>sha2 ( string -- string )
: byte-array>sha2 ( byte-array -- string )
t preprocess-plaintext
block-size get group [ process-chunk ] each
4 H get seq>string ;
4 H get seq>byte-array ;
PRIVATE>
: string>sha-256 ( string -- string )
: byte-array>sha-256 ( string -- string )
[
K-256 K set
initial-H-256 H set
4 word-size set
64 block-size set
\ >32-bit >word set
string>sha2
byte-array>sha2
] with-scope ;
: string>sha-256-string ( string -- hexstring )
string>sha-256 hex-string ;
: byte-array>sha-256-string ( string -- hexstring )
byte-array>sha-256 hex-string ;

26
extra/db/mysql/mysql.factor Normal file → Executable file
View File

@ -9,37 +9,37 @@ TUPLE: mysql-statement ;
TUPLE: mysql-result-set ;
M: mysql-db db-open ( mysql-db -- )
;
drop ;
M: mysql-db dispose ( mysql-db -- )
mysql-db-handle mysql_close ;
M: mysql-db <simple-statement> ( str -- statement )
;
M: mysql-db <simple-statement> ( str in out -- statement )
3drop f ;
M: mysql-db <prepared-statement> ( str -- statement )
;
M: mysql-db <prepared-statement> ( str in out -- statement )
3drop f ;
M: mysql-statement prepare-statement ( statement -- )
;
drop ;
M: mysql-statement bind-statement* ( statement -- )
;
drop ;
M: mysql-statement query-results ( query -- result-set )
;
drop f ;
M: mysql-result-set #rows ( result-set -- n )
;
drop 0 ;
M: mysql-result-set #columns ( result-set -- n )
;
drop 0 ;
M: mysql-result-set row-column ( result-set n -- obj )
;
2drop f ;
M: mysql-result-set advance-row ( result-set -- ? )
;
M: mysql-result-set advance-row ( result-set -- )
drop ;
M: mysql-db begin-transaction ( -- )
;

42
extra/db/sql/sql-tests.factor Normal file
View File

@ -0,0 +1,42 @@
USING: kernel db.sql ;
IN: db.sql.tests
TUPLE: person name age ;
: insert-1
{ insert
{ table "person" }
{ columns "name" "age" }
{ values "erg" 26 }
} ;
: update-1
{ update "person"
{ set { "name" "erg" }
{ "age" 6 } }
{ where { "age" 6 } }
} ;
: select-1
{ select
{ columns
"branchno"
{ count "staffno" as "mycount" }
{ sum "salary" as "mysum" } }
{ from "staff" "lol" }
{ where
{ "salary" > all
{ select
{ columns "salary" }
{ from "staff" }
{ where { "branchno" "b003" } }
}
}
{ "branchno" > 3 } }
{ group-by "branchno" "lol2" }
{ having { count "staffno" > 1 } }
{ order-by "branchno" }
{ offset 40 }
{ limit 20 }
} ;

69
extra/db/sql/sql.factor Executable file
View File

@ -0,0 +1,69 @@
USING: kernel parser quotations tuples words
namespaces.lib namespaces sequences arrays combinators
prettyprint strings math.parser sequences.lib math symbols ;
USE: tools.walker
IN: db.sql
SYMBOLS: insert update delete select distinct columns from as
where group-by having order-by limit offset is-null desc all
any count avg table values ;
: input-spec, 1, ;
: output-spec, 2, ;
: input, 3, ;
: output, 4, ;
DEFER: sql%
: (sql-interleave) ( seq sep -- )
[ sql% ] curry [ sql% ] interleave ;
: sql-interleave ( seq str sep -- )
swap sql% (sql-interleave) ;
: sql-function, ( seq function -- )
sql% "(" sql% unclip sql% ")" sql% [ sql% ] each ;
: sql-array% ( array -- )
unclip
{
{ columns [ "," (sql-interleave) ] }
{ from [ "from" "," sql-interleave ] }
{ where [ "where" "and" sql-interleave ] }
{ group-by [ "group by" "," sql-interleave ] }
{ having [ "having" "," sql-interleave ] }
{ order-by [ "order by" "," sql-interleave ] }
{ offset [ "offset" sql% sql% ] }
{ limit [ "limit" sql% sql% ] }
{ select [ "(select" sql% sql% ")" sql% ] }
{ table [ sql% ] }
{ set [ "set" "," sql-interleave ] }
{ values [ "values(" sql% "," (sql-interleave) ")" sql% ] }
{ count [ "count" sql-function, ] }
{ sum [ "sum" sql-function, ] }
{ avg [ "avg" sql-function, ] }
{ min [ "min" sql-function, ] }
{ max [ "max" sql-function, ] }
[ sql% [ sql% ] each ]
} case ;
TUPLE: no-sql-match ;
: sql% ( obj -- )
{
{ [ dup string? ] [ " " 0% 0% ] }
{ [ dup array? ] [ sql-array% ] }
{ [ dup number? ] [ number>string sql% ] }
{ [ dup symbol? ] [ unparse sql% ] }
{ [ dup word? ] [ unparse sql% ] }
{ [ t ] [ T{ no-sql-match } throw ] }
} cond ;
: parse-sql ( obj -- sql in-spec out-spec in out )
[
unclip {
{ insert [ "insert into" sql% ] }
{ update [ "update" sql% ] }
{ delete [ "delete" sql% ] }
{ select [ "select" sql% ] }
} case [ sql% ] each
] { "" { } { } { } { } } nmake ;

8
extra/db/sqlite/lib/lib.factor
View File

@ -3,8 +3,7 @@
USING: alien.c-types arrays assocs kernel math math.parser
namespaces sequences db.sqlite.ffi db combinators
continuations db.types calendar.format serialize
io.streams.string byte-arrays ;
USE: tools.walker
io.streams.byte-array byte-arrays io.encodings.binary ;
IN: db.sqlite.lib
: sqlite-error ( n -- * )
@ -94,7 +93,7 @@ IN: db.sqlite.lib
{ TIMESTAMP [ sqlite-bind-text-by-name ] }
{ BLOB [ sqlite-bind-blob-by-name ] }
{ FACTOR-BLOB [
[ serialize ] with-string-writer >byte-array
binary [ serialize ] with-byte-writer
sqlite-bind-blob-by-name
] }
{ +native-id+ [ sqlite-bind-int-by-name ] }
@ -137,7 +136,8 @@ IN: db.sqlite.lib
{ DATETIME [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] }
{ BLOB [ sqlite-column-blob ] }
{ FACTOR-BLOB [
sqlite-column-blob [ deserialize ] with-string-reader
sqlite-column-blob
binary [ deserialize ] with-byte-reader
] }
! { NULL [ 2drop f ] }
[ no-sql-type ]

9
extra/db/sqlite/sqlite.factor
View File

@ -4,7 +4,7 @@ USING: alien arrays assocs classes compiler db
hashtables io.files kernel math math.parser namespaces
prettyprint sequences strings tuples alien.c-types
continuations db.sqlite.lib db.sqlite.ffi db.tuples
words combinators.lib db.types combinators tools.walker
words combinators.lib db.types combinators
combinators.cleave io namespaces.lib ;
IN: db.sqlite
@ -22,14 +22,17 @@ M: sqlite-db db-close ( handle -- )
M: sqlite-db dispose ( db -- ) dispose-db ;
: with-sqlite ( path quot -- )
sqlite-db swap with-db ; inline
TUPLE: sqlite-statement ;
TUPLE: sqlite-result-set has-more? ;
M: sqlite-db <simple-statement> ( str -- obj )
M: sqlite-db <simple-statement> ( str in out -- obj )
<prepared-statement> ;
M: sqlite-db <prepared-statement> ( str -- obj )
M: sqlite-db <prepared-statement> ( str in out -- obj )
{
set-statement-sql
set-statement-in-params

41
extra/db/types/types.factor
View File

@ -3,8 +3,7 @@
USING: arrays assocs db kernel math math.parser
sequences continuations sequences.deep sequences.lib
words namespaces tools.walker slots slots.private classes
mirrors tuples combinators calendar.format serialize
io.streams.string ;
mirrors tuples combinators calendar.format symbols ;
IN: db.types
HOOK: modifier-table db ( -- hash )
@ -14,11 +13,10 @@ HOOK: create-type-table db ( -- hash )
HOOK: compound-type db ( str n -- hash )
TUPLE: sql-spec class slot-name column-name type modifiers primary-key ;
! ID is the Primary key
! +native-id+ can be a columns type or a modifier
SYMBOL: +native-id+
! +assigned-id+ can only be a modifier
SYMBOL: +assigned-id+
SYMBOLS: +native-id+ +assigned-id+ +autoincrement+
+serial+ +unique+ +default+ +null+ +not-null+
+foreign-id+ +has-many+ ;
: (primary-key?) ( obj -- ? )
{ +native-id+ +assigned-id+ } member? ;
@ -45,35 +43,10 @@ SYMBOL: +assigned-id+
: assigned-id? ( spec -- ? )
sql-spec-primary-key +assigned-id+ = ;
SYMBOL: +foreign-id+
! Same concept, SQLite has autoincrement, PostgreSQL has serial
SYMBOL: +autoincrement+
SYMBOL: +serial+
SYMBOL: +unique+
SYMBOL: +default+
SYMBOL: +null+
SYMBOL: +not-null+
SYMBOL: +has-many+
: relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
SYMBOL: INTEGER
SYMBOL: BIG-INTEGER
SYMBOL: DOUBLE
SYMBOL: REAL
SYMBOL: BOOLEAN
SYMBOL: TEXT
SYMBOL: VARCHAR
SYMBOL: DATE
SYMBOL: TIME
SYMBOL: DATETIME
SYMBOL: TIMESTAMP
SYMBOL: BLOB
SYMBOL: FACTOR-BLOB
SYMBOL: NULL
SYMBOLS: INTEGER BIG-INTEGER DOUBLE REAL BOOLEAN TEXT VARCHAR
DATE TIME DATETIME TIMESTAMP BLOB FACTOR-BLOB NULL ;
: spec>tuple ( class spec -- tuple )
[ ?first3 ] keep 3 ?tail*

0
unmaintained/gap-buffer/authors.txt → extra/digraphs/authors.txt
View File

9
extra/digraphs/digraphs-tests.factor Normal file
View File

@ -0,0 +1,9 @@
USING: digraphs kernel sequences tools.test ;
IN: digraphs.tests
: test-digraph ( -- digraph )
<digraph>
{ { "one" 1 } { "two" 2 } { "three" 3 } { "four" 4 } { "five" 5 } } [ first2 pick add-vertex ] each
{ { "one" "three" } { "one" "four" } { "two" "three" } { "two" "one" } { "three" "four" } } [ first2 pick add-edge ] each ;
[ 5 ] [ test-digraph topological-sort length ] unit-test

50
extra/digraphs/digraphs.factor Normal file
View File

@ -0,0 +1,50 @@
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel new-slots sequences vectors ;
IN: digraphs
TUPLE: digraph ;
TUPLE: vertex value edges ;
: <digraph> ( -- digraph )
digraph construct-empty H{ } clone over set-delegate ;
: <vertex> ( value -- vertex )
V{ } clone vertex construct-boa ;
: add-vertex ( key value digraph -- )
>r <vertex> swap r> set-at ;
: children ( key digraph -- seq )
at edges>> ;
: @edges ( from to digraph -- to edges ) swapd at edges>> ;
: add-edge ( from to digraph -- ) @edges push ;
: delete-edge ( from to digraph -- ) @edges delete ;
: delete-to-edges ( to digraph -- )
[ nip dupd edges>> delete ] assoc-each drop ;
: delete-vertex ( key digraph -- )
2dup delete-at delete-to-edges ;
: unvisited? ( unvisited key -- ? ) swap key? ;
: visited ( unvisited key -- ) swap delete-at ;
DEFER: (topological-sort)
: visit-children ( seq unvisited key -- seq unvisited )
over children [ (topological-sort) ] each ;
: (topological-sort) ( seq unvisited key -- seq unvisited )
2dup unvisited? [
[ visit-children ] keep 2dup visited pick push
] [
drop
] if ;
: topological-sort ( digraph -- seq )
dup clone V{ } clone spin
[ drop (topological-sort) ] assoc-each drop reverse ;
: topological-sorted-values ( digraph -- seq )
dup topological-sort swap [ at value>> ] curry map ;

1
extra/digraphs/summary.txt Normal file
View File

@ -0,0 +1 @@
Simple directed graph implementation for topological sorting

0
unmaintained/gap-buffer/cursortree/authors.txt → extra/gap-buffer/authors.txt
View File

1
extra/gap-buffer/cursortree/authors.txt Normal file
View File

@ -0,0 +1 @@
Alex Chapman

0
unmaintained/gap-buffer/cursortree/cursortree-tests.factor → extra/gap-buffer/cursortree/cursortree-tests.factor
View File

9
unmaintained/gap-buffer/cursortree/cursortree.factor → extra/gap-buffer/cursortree/cursortree.factor
View File

@ -1,12 +1,12 @@
! Copyright (C) 2007 Alex Chapman All Rights Reserved.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel gap-buffer generic trees trees.avl-tree math sequences quotations ;
USING: assocs kernel gap-buffer generic trees trees.avl math sequences quotations ;
IN: gap-buffer.cursortree
TUPLE: cursortree cursors ;
: <cursortree> ( seq -- cursortree )
<gb> cursortree construct-empty tuck set-delegate <avl-tree>
<gb> cursortree construct-empty tuck set-delegate <avl>
over set-cursortree-cursors ;
GENERIC: cursortree-gb ( cursortree -- gb )
@ -20,10 +20,11 @@ TUPLE: right-cursor ;
: cursor-index ( cursor -- i ) cursor-i ; inline
: add-cursor ( cursortree cursor -- ) dup cursor-index rot tree-insert ;
: add-cursor ( cursortree cursor -- ) dup cursor-index rot avl-insert ;
: remove-cursor ( cursortree cursor -- )
dup [ eq? ] curry swap cursor-index rot cursortree-cursors tree-delete-if ;
cursor-index swap delete-at ;
! dup [ eq? ] curry swap cursor-index rot cursortree-cursors tree-delete-if ;
: set-cursor-index ( index cursor -- )
dup cursor-tree over remove-cursor tuck set-cursor-i

0
unmaintained/gap-buffer/cursortree/summary.txt → extra/gap-buffer/cursortree/summary.txt
View File

0
unmaintained/gap-buffer/gap-buffer-tests.factor → extra/gap-buffer/gap-buffer-tests.factor
View File

2
unmaintained/gap-buffer/gap-buffer.factor → extra/gap-buffer/gap-buffer.factor
View File

@ -4,7 +4,7 @@
! gap buffer -- largely influenced by Strandh and Villeneuve's Flexichain
! for a good introduction see:
! http://p-cos.net/lisp-ecoop/submissions/StrandhVilleneuveMoore.pdf
USING: kernel arrays sequences sequences.private circular math generic ;
USING: kernel arrays sequences sequences.private circular math math.functions generic ;
IN: gap-buffer
! gap-start -- the first element of the gap

0
unmaintained/gap-buffer/summary.txt → extra/gap-buffer/summary.txt
View File

0
unmaintained/gap-buffer/tags.txt → extra/gap-buffer/tags.txt
View File

1
extra/hash2/hash2-tests.factor Normal file → Executable file
View File

@ -1,4 +1,5 @@
USING: tools.test hash2 kernel ;
IN: hash2.tests
: sample-hash
5 <hash2>

13
extra/hello-ui/deploy.factor
View File

@ -1,13 +1,14 @@
USING: tools.deploy.config ;
H{
{ deploy-math? t }
{ deploy-reflection 2 }
{ deploy-io 1 }
{ deploy-word-props? f }
{ deploy-word-defs? f }
{ "stop-after-last-window?" t }
{ deploy-ui? t }
{ deploy-compiler? t }
{ deploy-word-defs? f }
{ deploy-word-props? f }
{ deploy-math? t }
{ deploy-name "Hello world" }
{ deploy-c-types? f }
{ deploy-ui? t }
{ deploy-threads? t }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
}

14
extra/hooks/hooks-tests.factor Normal file
View File

@ -0,0 +1,14 @@
USING: hooks kernel tools.test ;
IN: hooks.tests
SYMBOL: test-hook
test-hook reset-hook
: add-test-hook test-hook add-hook ;
[ ] [ test-hook call-hook ] unit-test
[ "op called" ] [ "op" [ "op called" ] add-test-hook test-hook call-hook ] unit-test
[ "first called" "second called" ] [
test-hook reset-hook
"second op" [ "second called" ] add-test-hook
"first op" [ "first called" ] add-test-hook
test-hook call-hook
] unit-test

28
extra/hooks/hooks.factor Normal file
View File

@ -0,0 +1,28 @@
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: assocs digraphs kernel namespaces sequences ;
IN: hooks
: hooks ( -- hooks )
\ hooks global [ drop H{ } clone ] cache ;
: hook-graph ( hook -- graph )
hooks [ drop <digraph> ] cache ;
: reset-hook ( hook -- )
<digraph> swap hooks set-at ;
: add-hook ( key quot hook -- )
#! hook should be a symbol. Note that symbols with the same name but
#! different vocab are not equal
hook-graph add-vertex ;
: before ( key1 key2 hook -- )
hook-graph add-edge ;
: after ( key1 key2 hook -- )
swapd before ;
: call-hook ( hook -- )
hook-graph topological-sorted-values [ call ] each ;

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

@ -161,5 +161,6 @@ SYMBOL: html
"id" "onclick" "style" "valign" "accesskey"
"src" "language" "colspan" "onchange" "rel"
"width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
"media"
] [ define-attribute-word ] each
] with-compilation-unit

4
extra/http/client/client.factor
View File

@ -82,8 +82,8 @@ PRIVATE>
: download-to ( url file -- )
#! Downloads the contents of a URL to a file.
swap http-get-stream check-response
[ swap binary <file-writer> stream-copy ] with-disposal ;
swap http-get-stream swap check-response
[ swap latin1 <file-writer> stream-copy ] with-disposal ;
: download ( url -- )
dup download-name download-to ;

50
extra/http/server/authentication/basic/basic.factor
View File

@ -1,50 +0,0 @@
! Copyright (c) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
IN: http.server.authentication.basic
USING: accessors new-slots quotations assocs kernel splitting
base64 crypto.sha2 html.elements io combinators http.server
http sequences ;
! 'users' is a quotation or an assoc. The quotation
! has stack effect ( sha-256-string username -- ? ).
! It should perform the user authentication. 'sha-256-string'
! is the plain text password provided by the user passed through
! 'string>sha-256-string'. If 'users' is an assoc then
! it is a mapping of usernames to sha-256 hashed passwords.
TUPLE: realm responder name users ;
C: <realm> realm
: user-authorized? ( password username realm -- ? )
users>> {
{ [ dup callable? ] [ call ] }
{ [ dup assoc? ] [ at = ] }
} cond ;
: authorization-ok? ( realm header -- bool )
#! Given the realm and the 'Authorization' header,
#! authenticate the user.
dup [
" " split1 swap "Basic" = [
base64> ":" split1 string>sha-256-string
spin user-authorized?
] [
2drop f
] if
] [
2drop f
] if ;
: <401> ( realm -- response )
401 "Unauthorized" <trivial-response>
"Basic realm=\"" rot name>> "\"" 3append
"WWW-Authenticate" set-header
[
<html> <body>
"Username or Password is invalid" write
</body> </html>
] >>body ;
M: realm call-responder ( request path realm -- response )
pick "authorization" header dupd authorization-ok?
[ responder>> call-responder ] [ 2nip <401> ] if ;

7
extra/http/server/templating/fhtml/fhtml-tests.factor
View File

@ -1,5 +1,6 @@
USING: io io.files io.streams.string io.encodings.utf8
http.server.templating.fhtml kernel tools.test sequences ;
http.server.templating.fhtml kernel tools.test sequences
parser ;
IN: http.server.templating.fhtml.tests
: test-template ( path -- ? )
@ -14,4 +15,6 @@ IN: http.server.templating.fhtml.tests
[ t ] [ "bug" test-template ] unit-test
[ t ] [ "stack" test-template ] unit-test
[ ] [ "<%\n%>" parse-template drop ] unit-test
[
[ ] [ "<%\n%>" parse-template drop ] unit-test
] with-file-vocabs

24
extra/io/buffers/buffers-docs.factor Normal file → Executable file
View File

@ -1,8 +1,8 @@
USING: help.markup help.syntax strings alien ;
USING: help.markup help.syntax byte-arrays alien ;
IN: io.buffers
ARTICLE: "buffers" "Locked I/O buffers"
"I/O buffers are first-in-first-out queues of characters. Their key feature is that they are backed by manually allocated storage that does not get moved by the garbage collector. They are used to implement native I/O backends."
"I/O buffers are first-in-first-out queues of bytes. Their key feature is that they are backed by manually allocated storage that does not get moved by the garbage collector. They are used to implement native I/O backends."
$nl
"Buffer words are found in the " { $vocab-link "buffers" } " vocabulary."
{ $subsection buffer }
@ -23,7 +23,7 @@ $nl
{ $subsection buffer-until }
"Writing to the buffer:"
{ $subsection extend-buffer }
{ $subsection ch>buffer }
{ $subsection byte>buffer }
{ $subsection >buffer }
{ $subsection n>buffer } ;
@ -48,7 +48,7 @@ HELP: buffer-free
{ $warning "You " { $emphasis "must" } " free a buffer using this word, before letting the GC collect the buffer tuple instance." } ;
HELP: (buffer>>)
{ $values { "buffer" buffer } { "string" "a string" } }
{ $values { "buffer" buffer } { "byte-array" byte-array } }
{ $description "Collects the entire contents of the buffer into a string." } ;
HELP: buffer-reset
@ -68,15 +68,15 @@ HELP: buffer-end
{ $description "Outputs the memory address of the current fill-pointer." } ;
HELP: (buffer>)
{ $values { "n" "a non-negative integer" } { "buffer" buffer } { "string" string } }
{ $values { "n" "a non-negative integer" } { "buffer" buffer } { "byte-array" byte-array } }
{ $description "Outputs a string of the first " { $snippet "n" } " characters at the buffer's current position. If there are less than " { $snippet "n" } " characters available, the output is truncated." } ;
HELP: buffer>
{ $values { "n" "a non-negative integer" } { "buffer" buffer } { "string" "a string" } }
{ $values { "n" "a non-negative integer" } { "buffer" buffer } { "byte-array" byte-array } }
{ $description "Collects a string of " { $snippet "n" } " characters starting from the buffer's current position, and advances the position accordingly. If there are less than " { $snippet "n" } " characters available, the output is truncated." } ;
HELP: buffer>>
{ $values { "buffer" buffer } { "string" "a string" } }
{ $values { "buffer" buffer } { "byte-array" byte-array } }
{ $description "Collects the contents of the buffer into a string, and resets the position and fill pointer to 0." } ;
HELP: buffer-length
@ -102,11 +102,11 @@ HELP: check-overflow
{ $errors "Throws an error if the buffer contains unread data, and the new data does not fit." } ;
HELP: >buffer
{ $values { "string" "a string" } { "buffer" buffer } }
{ $values { "byte-array" byte-array } { "buffer" buffer } }
{ $description "Copies a string to the buffer's fill pointer, and advances it accordingly." } ;
HELP: ch>buffer
{ $values { "ch" "a character" } { "buffer" buffer } }
HELP: byte>buffer
{ $values { "byte" "a byte" } { "buffer" buffer } }
{ $description "Appends a single byte to a buffer." } ;
HELP: n>buffer
@ -123,5 +123,5 @@ HELP: buffer-pop
{ $description "Outputs the byte at the buffer position and advances the position." } ;
HELP: buffer-until
{ $values { "separators" string } { "buffer" buffer } { "string" string } { "separator" "a character or " { $link f } } }
{ $description "Searches the buffer for a character appearing in " { $snippet "separators" } ", starting from " { $link buffer-pos } ". If a separator is found, all data up to but not including the separator is output, together with the separator itself; otherwise the remainder of the buffer's contents are output together with " { $link f } "." } ;
{ $values { "separators" "a sequence of bytes" } { "buffer" buffer } { "byte-array" byte-array } { "separator" "a byte or " { $link f } } }
{ $description "Searches the buffer for a byte appearing in " { $snippet "separators" } ", starting from " { $link buffer-pos } ". If a separator is found, all data up to but not including the separator is output, together with the separator itself; otherwise the remainder of the buffer's contents are output together with " { $link f } "." } ;

30
extra/io/buffers/buffers-tests.factor
View File

@ -1,15 +1,15 @@
IN: io.buffers.tests
USING: alien alien.c-types io.buffers kernel kernel.private libc
sequences tools.test namespaces ;
sequences tools.test namespaces byte-arrays strings ;
: buffer-set ( string buffer -- )
2dup buffer-ptr string>char-memory
over >byte-array over buffer-ptr byte-array>memory
>r length r> buffer-reset ;
: string>buffer ( string -- buffer )
dup length <buffer> tuck buffer-set ;
[ "" 65536 ] [
[ B{ } 65536 ] [
65536 <buffer>
dup (buffer>>)
over buffer-capacity
@ -18,15 +18,15 @@ sequences tools.test namespaces ;
[ "hello world" "" ] [
"hello world" string>buffer
dup (buffer>>)
dup (buffer>>) >string
0 pick buffer-reset
over (buffer>>)
over (buffer>>) >string
rot buffer-free
] unit-test
[ "hello" ] [
"hello world" string>buffer
5 over buffer> swap buffer-free
5 over buffer> >string swap buffer-free
] unit-test
[ 11 ] [
@ -36,8 +36,8 @@ sequences tools.test namespaces ;
[ "hello world" ] [
"hello" 1024 <buffer> [ buffer-set ] keep
" world" over >buffer
dup (buffer>>) swap buffer-free
" world" >byte-array over >buffer
dup (buffer>>) >string swap buffer-free
] unit-test
[ CHAR: e ] [
@ -47,33 +47,33 @@ sequences tools.test namespaces ;
[ "hello" CHAR: \r ] [
"hello\rworld" string>buffer
"\r" over buffer-until
"\r" over buffer-until >r >string r>
rot buffer-free
] unit-test
[ "hello" CHAR: \r ] [
"hello\rworld" string>buffer
"\n\r" over buffer-until
"\n\r" over buffer-until >r >string r>
rot buffer-free
] unit-test
[ "hello\rworld" f ] [
"hello\rworld" string>buffer
"X" over buffer-until
"X" over buffer-until >r >string r>
rot buffer-free
] unit-test
[ "hello" CHAR: \r "world" CHAR: \n ] [
"hello\rworld\n" string>buffer
[ "\r\n" swap buffer-until ] keep
[ "\r\n" swap buffer-until ] keep
[ "\r\n" swap buffer-until >r >string r> ] keep
[ "\r\n" swap buffer-until >r >string r> ] keep
buffer-free
] unit-test
"hello world" string>buffer "b" set
[ "hello world" ] [ 1000 "b" get buffer> ] unit-test
[ "hello world" ] [ 1000 "b" get buffer> >string ] unit-test
"b" get buffer-free
100 <buffer> "b" set
[ 1000 "b" get n>buffer ] must-fail
[ 1000 "b" get n>buffer >string ] must-fail
"b" get buffer-free

24
extra/io/buffers/buffers.factor
View File

@ -3,7 +3,7 @@
! See http://factorcode.org/license.txt for BSD license.
IN: io.buffers
USING: alien alien.accessors alien.c-types alien.syntax kernel
kernel.private libc math sequences strings hints ;
kernel.private libc math sequences byte-arrays strings hints ;
TUPLE: buffer size ptr fill pos ;
@ -37,18 +37,18 @@ TUPLE: buffer size ptr fill pos ;
: buffer-pop ( buffer -- ch )
dup buffer-peek 1 rot buffer-consume ;
: (buffer>) ( n buffer -- string )
: (buffer>) ( n buffer -- byte-array )
[ dup buffer-fill swap buffer-pos - min ] keep
buffer@ swap memory>char-string ;
buffer@ swap memory>byte-array ;
: buffer> ( n buffer -- string )
: buffer> ( n buffer -- byte-array )
[ (buffer>) ] 2keep buffer-consume ;
: (buffer>>) ( buffer -- string )
: (buffer>>) ( buffer -- byte-array )
dup buffer-pos over buffer-ptr <displaced-alien>
over buffer-fill rot buffer-pos - memory>char-string ;
over buffer-fill rot buffer-pos - memory>byte-array ;
: buffer>> ( buffer -- string )
: buffer>> ( buffer -- byte-array )
dup (buffer>>) 0 rot buffer-reset ;
: search-buffer-until ( start end alien separators -- n )
@ -56,7 +56,7 @@ TUPLE: buffer size ptr fill pos ;
HINTS: search-buffer-until { fixnum fixnum simple-alien string } ;
: finish-buffer-until ( buffer n -- string separator )
: finish-buffer-until ( buffer n -- byte-array separator )
[
over buffer-pos -
over buffer>
@ -65,7 +65,7 @@ HINTS: search-buffer-until { fixnum fixnum simple-alien string } ;
buffer>> f
] if* ;
: buffer-until ( separators buffer -- string separator )
: buffer-until ( separators buffer -- byte-array separator )
tuck { buffer-pos buffer-fill buffer-ptr } get-slots roll
search-buffer-until finish-buffer-until ;
@ -85,12 +85,12 @@ HINTS: search-buffer-until { fixnum fixnum simple-alien string } ;
: check-overflow ( n buffer -- )
2dup buffer-capacity > [ extend-buffer ] [ 2drop ] if ;
: >buffer ( string buffer -- )
: >buffer ( byte-array buffer -- )
over length over check-overflow
[ buffer-end string>char-memory ] 2keep
[ buffer-end byte-array>memory ] 2keep
[ buffer-fill swap length + ] keep set-buffer-fill ;
: ch>buffer ( ch buffer -- )
: byte>buffer ( ch buffer -- )
1 over check-overflow
[ buffer-end 0 set-alien-unsigned-1 ] keep
[ buffer-fill 1+ ] keep set-buffer-fill ;

3
extra/io/encodings/latin1/latin1.factor
View File

@ -7,3 +7,6 @@ TUPLE: latin1 ;
M: latin1 stream-write-encoded
drop 256 encode-check< ;
M: latin1 decode-step
drop swap push ;

5
extra/io/files/tmp/tmp-tests.factor Normal file
View File

@ -0,0 +1,5 @@
USING: io.files io.files.tmp kernel strings tools.test ;
IN: temporary
[ t ] [ tmpdir string? ] unit-test
[ t f ] [ ".tmp" [ dup exists? swap ] with-tmpfile exists? ] unit-test

22
extra/io/files/tmp/tmp.factor Normal file
View File

@ -0,0 +1,22 @@
USING: continuations io io.files kernel sequences strings.lib ;
IN: io.files.tmp
: tmpdir ( -- dirname )
#! ensure that a tmp dir exists and return its name
#! I'm using a sub-directory of factor for crossplatconformity (windows doesn't have /tmp)
"tmp" resource-path dup directory? [ dup make-directory ] unless ;
: touch ( filename -- )
<file-writer> dispose ;
: tmpfile ( extension -- filename )
16 random-alphanumeric-string over append
tmpdir swap path+ dup exists? [
drop tmpfile
] [
nip dup touch
] if ;
: with-tmpfile ( extension quot -- )
#! quot should have stack effect ( filename -- )
swap tmpfile tuck swap curry swap [ delete-file ] curry [ ] cleanup ;

2
extra/io/mmap/mmap-tests.factor
View File

@ -3,7 +3,7 @@ sequences io.encodings.ascii ;
IN: io.mmap.tests
[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors
[ ] [ "mmap-test-file.txt" resource-path ascii [ "12345" write ] with-file-writer ] unit-test
[ ] [ "12345" "mmap-test-file.txt" resource-path ascii set-file-contents ] unit-test
[ ] [ "mmap-test-file.txt" resource-path dup file-length [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
[ 5 ] [ "mmap-test-file.txt" resource-path dup file-length [ length ] with-mapped-file ] unit-test
[ "22345" ] [ "mmap-test-file.txt" resource-path ascii file-contents ] unit-test

8
extra/io/nonblocking/nonblocking-docs.factor
View File

@ -1,5 +1,5 @@
USING: io io.buffers io.backend help.markup help.syntax kernel
strings sbufs words continuations ;
byte-arrays sbufs words continuations byte-vectors ;
IN: io.nonblocking
ARTICLE: "io.nonblocking" "Non-blocking I/O implementation"
@ -93,12 +93,12 @@ HELP: unless-eof
{ $description "If the port has reached end of file, outputs " { $link f } ", otherwise applies the quotation to the port." } ;
HELP: read-until-step
{ $values { "separators" string } { "port" input-port } { "string/f" "a string or " { $link f } } { "separator/f" "a character or " { $link f } } }
{ $values { "separators" "a sequence of bytes" } { "port" input-port } { "byte-array/f" "a byte array or " { $link f } } { "separator/f" "a byte or " { $link f } } }
{ $description "If the port has reached end of file, outputs " { $link f } { $link f } ", otherwise scans the buffer for a separator and outputs a string up to but not including the separator." } ;
HELP: read-until-loop
{ $values { "seps" string } { "port" input-port } { "sbuf" sbuf } { "separator/f" "a character or " { $link f } } }
{ $description "Accumulates data in the string buffer, calling " { $link (wait-to-read) } " as many times as necessary, until either an occurrence of a separator is read, or end of file is reached." } ;
{ $values { "seps" "a sequence of bytes" } { "port" input-port } { "accum" byte-vector } { "separator/f" "a byte or " { $link f } } }
{ $description "Accumulates data in the byte vector, calling " { $link (wait-to-read) } " as many times as necessary, until either an occurrence of a separator is read, or end of file is reached." } ;
HELP: can-write?
{ $values { "len" "a positive integer" } { "writer" output-port } { "?" "a boolean" } }

4
extra/io/nonblocking/nonblocking.factor
View File

@ -75,7 +75,7 @@ M: input-port stream-read1
[ wait-to-read ] 2keep
[ dupd buffer> ] unless-eof nip ;
: read-loop ( count port sbuf -- )
: read-loop ( count port accum -- )
pick over length - dup 0 > [
pick read-step dup [
over push-all read-loop
@ -143,7 +143,7 @@ M: input-port stream-read-partial ( max stream -- byte-array/f )
tuck can-write? [ drop ] [ stream-flush ] if ;
M: output-port stream-write1
1 over wait-to-write ch>buffer ;
1 over wait-to-write byte>buffer ;
M: output-port stream-write
over length over buffer-size > [

2
extra/io/unix/files/files.factor
View File

@ -68,7 +68,7 @@ M: unix-io delete-directory ( path -- )
] with-disposal ;
M: unix-io copy-file ( from to -- )
>r dup file-permissions over r> (copy-file) chmod io-error ;
[ (copy-file) ] 2keep swap file-permissions chmod io-error ;
: stat>type ( stat -- type )
stat-st_mode {

20
extra/io/windows/files/files.factor
View File

@ -3,23 +3,13 @@
USING: alien.c-types io.files io.windows kernel
math windows windows.kernel32 combinators.cleave
windows.time calendar combinators math.functions
sequences combinators.lib namespaces words ;
sequences combinators.lib namespaces words symbols ;
IN: io.windows.files
SYMBOL: +read-only+
SYMBOL: +hidden+
SYMBOL: +system+
SYMBOL: +directory+
SYMBOL: +archive+
SYMBOL: +device+
SYMBOL: +normal+
SYMBOL: +temporary+
SYMBOL: +sparse-file+
SYMBOL: +reparse-point+
SYMBOL: +compressed+
SYMBOL: +offline+
SYMBOL: +not-content-indexed+
SYMBOL: +encrypted+
SYMBOLS: +read-only+ +hidden+ +system+
+directory+ +archive+ +device+ +normal+ +temporary+
+sparse-file+ +reparse-point+ +compressed+ +offline+
+not-content-indexed+ +encrypted+ ;
: expand-constants ( word/obj -- obj'/obj )
dup word? [ execute ] when ;

5
extra/io/windows/nt/monitors/monitors.factor
View File

@ -5,7 +5,7 @@ io.windows.nt.backend kernel math windows windows.kernel32
windows.types libc assocs alien namespaces continuations
io.monitors io.monitors.private io.nonblocking io.buffers
io.files io.timeouts io sequences hashtables sorting arrays
combinators math.bitfields ;
combinators math.bitfields strings ;
IN: io.windows.nt.monitors
: open-directory ( path -- handle )
@ -66,6 +66,9 @@ M: windows-nt-io <monitor> ( path recursive? -- monitor )
{ [ t ] [ +modify-file+ ] }
} cond nip ;
: memory>u16-string ( alien len -- string )
[ memory>byte-array ] keep 2/ c-ushort-array> >string ;
: parse-file-notify ( buffer -- changed path )
{
FILE_NOTIFY_INFORMATION-FileName

0
extra/jamshred/authors.txt Executable file → Normal file
View File

2
extra/jamshred/game/game.factor
View File

@ -1,3 +1,5 @@
! Copyright (C) 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: kernel opengl arrays sequences jamshred.tunnel
jamshred.player math.vectors ;
IN: jamshred.game

2
extra/jamshred/gl/gl.factor
View File

@ -1,3 +1,5 @@
! Copyright (C) 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types colors jamshred.game jamshred.oint
jamshred.player jamshred.tunnel kernel math math.vectors opengl
opengl.gl opengl.glu sequences ;

18
extra/jamshred/jamshred.factor
View File

@ -1,9 +1,11 @@
USING: arrays jamshred.game jamshred.gl kernel math math.constants
namespaces sequences timers ui ui.gadgets ui.gestures ui.render
! Copyright (C) 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: alarms arrays calendar jamshred.game jamshred.gl kernel math
math.constants namespaces sequences ui ui.gadgets ui.gestures ui.render
math.vectors ;
IN: jamshred
TUPLE: jamshred-gadget jamshred last-hand-loc ;
TUPLE: jamshred-gadget jamshred last-hand-loc alarm ;
: <jamshred-gadget> ( jamshred -- gadget )
jamshred-gadget construct-gadget tuck set-jamshred-gadget-jamshred ;
@ -17,13 +19,17 @@ M: jamshred-gadget pref-dim*
M: jamshred-gadget draw-gadget* ( gadget -- )
dup jamshred-gadget-jamshred swap rect-dim first2 draw-jamshred ;
M: jamshred-gadget tick ( gadget -- )
: tick ( gadget -- )
dup jamshred-gadget-jamshred jamshred-update relayout-1 ;
M: jamshred-gadget graft* ( gadget -- )
10 1 add-timer ;
[
[ tick ] curry 10 milliseconds from-now 10 milliseconds add-alarm
] keep set-jamshred-gadget-alarm ;
M: jamshred-gadget ungraft* ( gadget -- ) remove-timer ;
M: jamshred-gadget ungraft* ( gadget -- )
[ jamshred-gadget-alarm cancel-alarm f ] keep
set-jamshred-gadget-alarm ;
: jamshred-restart ( jamshred-gadget -- )
<jamshred> swap set-jamshred-gadget-jamshred ;

2
extra/jamshred/oint/oint.factor
View File

@ -1,3 +1,5 @@
! Copyright (C) 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: arrays float-arrays kernel math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ;
IN: jamshred.oint

2
extra/jamshred/player/player.factor
View File

@ -1,3 +1,5 @@
! Copyright (C) 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: colors jamshred.oint jamshred.tunnel kernel
math math.constants sequences ;
IN: jamshred.player

1
extra/jamshred/summary.txt Normal file
View File

@ -0,0 +1 @@
A simple 3d tunnel racing game

2
extra/jamshred/tags.txt Normal file
View File

@ -0,0 +1,2 @@
applications
games

2
extra/jamshred/tunnel/tunnel-tests.factor
View File

@ -1,3 +1,5 @@
! Copyright (C) 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: jamshred.oint jamshred.tunnel kernel sequences tools.test ;
IN: jamshred.tunnel.tests

2
extra/jamshred/tunnel/tunnel.factor
View File

@ -1,3 +1,5 @@
! Copyright (C) 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: arrays float-arrays kernel jamshred.oint math math.functions
math.ranges math.vectors math.constants random sequences vectors ;
IN: jamshred.tunnel

3
extra/koszul/koszul-tests.factor Normal file → Executable file
View File

@ -1,4 +1,5 @@
USING: koszul tools.test kernel sequences assocs namespaces ;
USING: koszul tools.test kernel sequences assocs namespaces
symbols ;
IN: koszul.tests
[

6
extra/koszul/koszul.factor
View File

@ -3,14 +3,10 @@
USING: arrays assocs hashtables assocs io kernel math
math.vectors math.matrices math.matrices.elimination namespaces
parser prettyprint sequences words combinators math.parser
splitting sorting shuffle ;
splitting sorting shuffle symbols ;
IN: koszul
! Utilities
: SYMBOLS:
";" parse-tokens [ create-in define-symbol ] each ;
parsing
: -1^ odd? -1 1 ? ;
: >alt ( obj -- vec )

57
extra/ldap/ldap-tests.factor Normal file → Executable file
View File

@ -1,57 +1,58 @@
USING: alien alien.c-types io kernel ldap ldap.libldap namespaces prettyprint
tools.test ;
USING: alien alien.c-types io kernel ldap ldap.libldap
namespaces prettyprint tools.test ;
IN: ldap.tests
"void*" <c-object> "ldap://localhost:389" initialize
get-ldp LDAP_OPT_PROTOCOL_VERSION LDAP_VERSION3 <int> set-option
[ 3 ] [
[ 3 ] [
get-ldp LDAP_OPT_PROTOCOL_VERSION "int*" <c-object> [ get-option ] keep
*int
] unit-test
[
get-ldp "cn=jimbob,dc=example,dc=com" "secret" [
get-ldp "cn=jimbob,dc=example,dc=com" "secret" [
! get-ldp "dc=example,dc=com" LDAP_SCOPE_ONELEVEL "(objectclass=*)" f 0
! "void*" <c-object> [ search-s ] keep *int .
! get-ldp "dc=example,dc=com" LDAP_SCOPE_ONELEVEL "(objectclass=*)" f 0
! "void*" <c-object> [ search-s ] keep *int .
[ 2 ] [
get-ldp "dc=example,dc=com" LDAP_SCOPE_SUBTREE "(objectclass=*)" f 0
search
] unit-test
[ 2 ] [
get-ldp "dc=example,dc=com" LDAP_SCOPE_SUBTREE "(objectclass=*)" f 0
search
] unit-test
! get-ldp LDAP_RES_ANY 0 f "void*" <c-object> result .
! get-ldp LDAP_RES_ANY 0 f "void*" <c-object> result .
get-ldp LDAP_RES_ANY LDAP_MSG_ALL f "void*" <c-object> result
get-ldp LDAP_RES_ANY LDAP_MSG_ALL f "void*" <c-object> result
! get-message *int .
! get-message *int .
"Message ID: " write
"Message ID: " write
get-message msgid .
get-message msgid .
get-ldp get-message get-dn .
get-ldp get-message get-dn .
"Entries count: " write
"Entries count: " write
get-ldp get-message count-entries .
get-ldp get-message count-entries .
SYMBOL: entry
SYMBOL: attr
SYMBOL: entry
SYMBOL: attr
"Attribute: " write
"Attribute: " write
get-ldp get-message first-entry entry set get-ldp entry get
"void*" <c-object> first-attribute dup . attr set
get-ldp get-message first-entry entry set get-ldp entry get
"void*" <c-object> first-attribute dup . attr set
"Value: " write
"Value: " write
get-ldp entry get attr get get-values *char* .
get-ldp entry get attr get get-values *char* .
get-ldp get-message first-message msgtype result-type
get-ldp get-message first-message msgtype result-type
get-ldp get-message next-message msgtype result-type
get-ldp get-message next-message msgtype result-type
] with-bind
] with-bind
] drop

25
extra/morse/morse-docs.factor Normal file
View File

@ -0,0 +1,25 @@
! Copyright (C) 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax ;
IN: morse
HELP: ch>morse
{ $values
{ "ch" "A character that has a morse code translation" } { "str" "A string consisting of zero or more dots and dashes" } }
{ $description "If the given character has a morse code translation, then return that translation, otherwise return an empty string." } ;
HELP: morse>ch
{ $values
{ "str" "A string of dots and dashes that represents a single character in morse code" } { "ch" "The translated character" } }
{ $description "If the given string represents a morse code character, then return that character, otherwise return f" } ;
HELP: >morse
{ $values
{ "str" "A string of ASCII characters which can be translated into morse code" } { "str" "A string in morse code" } }
{ $description "Translates ASCII text into morse code, represented by a series of dots, dashes, and slashes." }
{ $see-also morse> ch>morse } ;
HELP: morse>
{ $values { "str" "A string of morse code, in which the character '.' represents dots, '-' dashes, ' ' spaces between letters, and ' / ' spaces between words." } { "str" "The ASCII translation of the given string" } }
{ $description "Translates morse code into ASCII text" }
{ $see-also >morse morse>ch } ;

11
extra/morse/morse-tests.factor Normal file
View File

@ -0,0 +1,11 @@
! Copyright (C) 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: arrays morse strings tools.test ;
[ "" ] [ CHAR: \\ ch>morse ] unit-test
[ "..." ] [ CHAR: s ch>morse ] unit-test
[ CHAR: s ] [ "..." morse>ch ] unit-test
[ f ] [ "..--..--.." morse>ch ] unit-test
[ "-- --- .-. ... . / -.-. --- -.. ." ] [ "morse code" >morse ] unit-test
[ "morse code" ] [ "-- --- .-. ... . / -.-. --- -.. ." morse> ] unit-test
[ "hello, world!" ] [ "Hello, World!" >morse morse> ] unit-test

125
extra/morse/morse.factor Normal file
View File

@ -0,0 +1,125 @@
! Copyright (C) 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: assocs hashtables kernel lazy-lists namespaces openal
parser-combinators promises sequences strings unicode.case ;
IN: morse
<PRIVATE
: morse-codes ( -- array )
{
{ CHAR: a ".-" }
{ CHAR: b "-..." }
{ CHAR: c "-.-." }
{ CHAR: d "-.." }
{ CHAR: e "." }
{ CHAR: f "..-." }
{ CHAR: g "--." }
{ CHAR: h "...." }
{ CHAR: i ".." }
{ CHAR: j ".---" }
{ CHAR: k "-.-" }
{ CHAR: l ".-.." }
{ CHAR: m "--" }
{ CHAR: n "-." }
{ CHAR: o "---" }
{ CHAR: p ".--." }
{ CHAR: q "--.-" }
{ CHAR: r ".-." }
{ CHAR: s "..." }
{ CHAR: t "-" }
{ CHAR: u "..-" }
{ CHAR: v "...-" }
{ CHAR: w ".--" }
{ CHAR: x "-..-" }
{ CHAR: y "-.--" }
{ CHAR: z "--.." }
{ CHAR: 1 ".----" }
{ CHAR: 2 "..---" }
{ CHAR: 3 "...--" }
{ CHAR: 4 "....-" }
{ CHAR: 5 "....." }
{ CHAR: 6 "-...." }
{ CHAR: 7 "--..." }
{ CHAR: 8 "---.." }
{ CHAR: 9 "----." }
{ CHAR: 0 "-----" }
{ CHAR: . ".-.-.-" }
{ CHAR: , "--..--" }
{ CHAR: ? "..--.." }
{ CHAR: ' ".----." }
{ CHAR: ! "-.-.--" }
{ CHAR: / "-..-." }
{ CHAR: ( "-.--." }
{ CHAR: ) "-.--.-" }
{ CHAR: & ".-..." }
{ CHAR: : "---..." }
{ CHAR: ; "-.-.-." }
{ CHAR: = "-...- " }
{ CHAR: + ".-.-." }
{ CHAR: - "-....-" }
{ CHAR: _ "..--.-" }
{ CHAR: " ".-..-." }
{ CHAR: $ "...-..-" }
{ CHAR: @ ".--.-." }
{ CHAR: \s "/" }
} ;
: ch>morse-assoc ( -- assoc )
morse-codes >hashtable ;
: morse>ch-assoc ( -- assoc )
morse-codes [ reverse ] map >hashtable ;
PRIVATE>
: ch>morse ( ch -- str )
ch>lower ch>morse-assoc at* swap "" ? ;
: morse>ch ( str -- ch )
morse>ch-assoc at* swap f ? ;
: >morse ( str -- str )
[
[ CHAR: \s , ] [ ch>morse % ] interleave
] "" make ;
<PRIVATE
: dot ( -- ch ) CHAR: . ;
: dash ( -- ch ) CHAR: - ;
: char-gap ( -- ch ) CHAR: \s ;
: word-gap ( -- ch ) CHAR: / ;
: =parser ( obj -- parser )
[ = ] curry satisfy ;
LAZY: 'dot' ( -- parser )
dot =parser ;
LAZY: 'dash' ( -- parser )
dash =parser ;
LAZY: 'char-gap' ( -- parser )
char-gap =parser ;
LAZY: 'word-gap' ( -- parser )
word-gap =parser ;
LAZY: 'morse-char' ( -- parser )
'dot' 'dash' <|> <+> ;
LAZY: 'morse-word' ( -- parser )
'morse-char' 'char-gap' list-of ;
LAZY: 'morse-words' ( -- parser )
'morse-word' 'word-gap' list-of ;
PRIVATE>
: morse> ( str -- str )
'morse-words' parse car parse-result-parsed [
[
>string morse>ch
] map >string
] map [ [ CHAR: \s , ] [ % ] interleave ] "" make ;

12
extra/msxml-to-csv/msxml-to-csv.factor
View File

@ -1,8 +1,7 @@
USING: io io.files sequences xml xml.utilities io.encodings.utf8 ;
USING: io io.files sequences xml xml.utilities
io.encodings.ascii kernel ;
IN: msxml-to-csv
: print-csv ( table -- ) [ "," join print ] each ;
: (msxml>csv) ( xml -- table )
"Worksheet" tag-named
"Table" tag-named
@ -12,7 +11,6 @@ IN: msxml-to-csv
] map
] map ;
: msxml>csv ( infile outfile -- )
utf8 [
file>xml (msxml>csv) print-csv
] with-file-writer ;
: msxml>csv ( outfile infile -- )
file>xml (msxml>csv) [ "," join ] map
swap ascii set-file-lines ;

1
extra/multiline/multiline-tests.factor Normal file → Executable file
View File

@ -1,4 +1,5 @@
USING: multiline tools.test ;
IN: multiline.tests
STRING: test-it
foo

6
extra/namespaces/lib/lib.factor
View File

@ -35,6 +35,12 @@ SYMBOL: building-seq
: 2, 2 n, ;
: 2% 2 n% ;
: 2# 2 n# ;
: 3, 3 n, ;
: 3% 3 n% ;
: 3# 3 n# ;
: 4, 4 n, ;
: 4% 4 n% ;
: 4# 4 n# ;
: nmake ( quot exemplars -- seqs )
dup length dup zero? [ 1+ ] when

62
extra/oracle/oracle-tests.factor Normal file → Executable file
View File

@ -1,57 +1,59 @@
USING: oracle oracle.liboci prettyprint tools.test ;
"testuser" "testpassword" "//localhost/test1" log-on .
[
"testuser" "testpassword" "//localhost/test1" log-on .
allocate-statement-handle
allocate-statement-handle
"CREATE TABLE TESTTABLE ( COL1 VARCHAR(40), COL2 NUMBER)" prepare-statement
"CREATE TABLE TESTTABLE ( COL1 VARCHAR(40), COL2 NUMBER)" prepare-statement
[ t ] [ execute-statement ] unit-test
[ t ] [ execute-statement ] unit-test
"INSERT INTO TESTTABLE (COL1, COL2) VALUES('hello', 50)" prepare-statement
"INSERT INTO TESTTABLE (COL1, COL2) VALUES('hello', 50)" prepare-statement
[ t ] [ execute-statement ] unit-test
[ t ] [ execute-statement ] unit-test
"INSERT INTO TESTTABLE (COL1, COL2) VALUES('hi', 60)" prepare-statement
"INSERT INTO TESTTABLE (COL1, COL2) VALUES('hi', 60)" prepare-statement
[ t ] [ execute-statement ] unit-test
[ t ] [ execute-statement ] unit-test
"INSERT INTO TESTTABLE (COL1, COL2) VALUES('bye', 70)" prepare-statement
"INSERT INTO TESTTABLE (COL1, COL2) VALUES('bye', 70)" prepare-statement
[ t ] [ execute-statement ] unit-test
[ t ] [ execute-statement ] unit-test
"COMMIT" prepare-statement
"COMMIT" prepare-statement
[ t ] [ execute-statement ] unit-test
[ t ] [ execute-statement ] unit-test
"SELECT * FROM TESTTABLE" prepare-statement
"SELECT * FROM TESTTABLE" prepare-statement
1 SQLT_STR define-by-position run-query
1 SQLT_STR define-by-position run-query
[ V{ "hello" "hi" "bye" "50" "60" "70" } ] [
2 SQLT_STR define-by-position run-query gather-results
] unit-test
[ V{ "hello" "hi" "bye" "50" "60" "70" } ] [
2 SQLT_STR define-by-position run-query gather-results
] unit-test
clear-result
clear-result
"UPDATE TESTTABLE SET COL2 = 10 WHERE COL1='hi'" prepare-statement
"UPDATE TESTTABLE SET COL2 = 10 WHERE COL1='hi'" prepare-statement
[ t ] [ execute-statement ] unit-test
[ t ] [ execute-statement ] unit-test
"COMMIT" prepare-statement
"COMMIT" prepare-statement
[ t ] [ execute-statement ] unit-test
[ t ] [ execute-statement ] unit-test
"SELECT * FROM TESTTABLE WHERE COL1 = 'hi'" prepare-statement
"SELECT * FROM TESTTABLE WHERE COL1 = 'hi'" prepare-statement
[ V{ "10" } ] [
2 SQLT_STR define-by-position run-query gather-results
] unit-test
[ V{ "10" } ] [
2 SQLT_STR define-by-position run-query gather-results
] unit-test
clear-result
clear-result
"DROP TABLE TESTTABLE" prepare-statement
"DROP TABLE TESTTABLE" prepare-statement
execute-statement
execute-statement
free-statement-handle log-off clean-up terminate
free-statement-handle log-off clean-up terminate
] drop

1
extra/pdf/pdf-tests.factor Normal file → Executable file
View File

@ -1,4 +1,5 @@
USING: io.files kernel math namespaces pdf pdf.libhpdf prettyprint sequences ;
IN: pdf.tests
SYMBOL: font

7
extra/project-euler/022/022.factor
View File

@ -1,6 +1,7 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: ascii io.files kernel math project-euler.common sequences sorting splitting ;
USING: ascii io.encodings.ascii io.files kernel math project-euler.common
sequences sequences.lib sorting splitting ;
IN: project-euler.022
! http://projecteuler.net/index.php?section=problems&id=22
@ -28,10 +29,10 @@ IN: project-euler.022
: source-022 ( -- seq )
"extra/project-euler/022/names.txt" resource-path
file-contents [ quotable? ] subset "," split ;
ascii file-contents [ quotable? ] subset "," split ;
: name-scores ( seq -- seq )
dup length [ 1+ swap alpha-value * ] 2map ;
[ 1+ swap alpha-value * ] map-index ;
PRIVATE>

96
extra/project-euler/047/047.factor Normal file
View File

@ -0,0 +1,96 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators.lib kernel math math.primes math.primes.factors
math.ranges namespaces sequences ;
IN: project-euler.047
! http://projecteuler.net/index.php?section=problems&id=47
! DESCRIPTION
! -----------
! The first two consecutive numbers to have two distinct prime factors are:
! 14 = 2 * 7
! 15 = 3 * 5
! The first three consecutive numbers to have three distinct prime factors are:
! 644 = 2² * 7 * 23
! 645 = 3 * 5 * 43
! 646 = 2 * 17 * 19.
! Find the first four consecutive integers to have four distinct primes
! factors. What is the first of these numbers?
! SOLUTION
! --------
! Brute force, not sure why it's incredibly slow compared to other languages
<PRIVATE
: (consecutive) ( count goal test -- n )
pick pick = [
swap - nip
] [
dup prime? [ [ drop 0 ] dipd ] [
2dup unique-factors length = [ [ 1+ ] dipd ] [ [ drop 0 ] dipd ] if
] if 1+ (consecutive)
] if ;
: consecutive ( goal test -- n )
0 -rot (consecutive) ;
PRIVATE>
: euler047 ( -- answer )
4 646 consecutive ;
! [ euler047 ] time
! 542708 ms run / 60548 ms GC time
! ALTERNATE SOLUTIONS
! -------------------
! Use a sieve to generate prime factor counts up to an arbitrary limit, then
! look for a repetition of the specified number of factors.
<PRIVATE
SYMBOL: sieve
: initialize-sieve ( n -- )
0 <repetition> >array sieve set ;
: is-prime? ( index -- ? )
sieve get nth zero? ;
: multiples ( n -- seq )
sieve get length 1- over <range> ;
: increment-counts ( n -- )
multiples [ sieve get [ 1+ ] change-nth ] each ;
: prime-tau-upto ( limit -- seq )
dup initialize-sieve 2 swap [a,b) [
dup is-prime? [ increment-counts ] [ drop ] if
] each sieve get ;
: consecutive-under ( m limit -- n/f )
prime-tau-upto [ dup <repetition> ] dip start ;
PRIVATE>
: euler047a ( -- answer )
4 200000 consecutive-under ;
! [ euler047a ] 100 ave-time
! 503 ms run / 5 ms GC ave time - 100 trials
! 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

92
extra/project-euler/059/059.factor Normal file
View File

@ -0,0 +1,92 @@
! Copyright (c) 2008 Aaron Schaefer, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays ascii assocs hashtables io.encodings.ascii io.files kernel math
math.parser namespaces sequences sequences.lib sequences.private sorting
splitting strings ;
IN: project-euler.059
! http://projecteuler.net/index.php?section=problems&id=59
! DESCRIPTION
! -----------
! Each character on a computer is assigned a unique code and the preferred
! standard is ASCII (American Standard Code for Information Interchange). For
! example, uppercase A = 65, asterisk (*) = 42, and lowercase k = 107.
! A modern encryption method is to take a text file, convert the bytes to
! ASCII, then XOR each byte with a given value, taken from a secret key. The
! advantage with the XOR function is that using the same encryption key on the
! cipher text, restores the plain text; for example, 65 XOR 42 = 107, then 107
! XOR 42 = 65.
! For unbreakable encryption, the key is the same length as the plain text
! message, and the key is made up of random bytes. The user would keep the
! encrypted message and the encryption key in different locations, and without
! both "halves", it is impossible to decrypt the message.
! Unfortunately, this method is impractical for most users, so the modified
! method is to use a password as a key. If the password is shorter than the
! message, which is likely, the key is repeated cyclically throughout the
! message. The balance for this method is using a sufficiently long password
! key for security, but short enough to be memorable.
! Your task has been made easy, as the encryption key consists of three lower
! case characters. Using cipher1.txt (right click and 'Save Link/Target
! As...'), a file containing the encrypted ASCII codes, and the knowledge that
! the plain text must contain common English words, decrypt the message and
! find the sum of the ASCII values in the original text.
! SOLUTION
! --------
! Assume that the space character will be the most common, so XOR the input
! text with a space character then group the text into three "columns" since
! that's how long our key is. Then do frequency analysis on each column to
! find out what the most likely candidate is for the key.
! NOTE: This technique would probably not work well in all cases, but luckily
! it did for this particular problem.
<PRIVATE
: source-059 ( -- seq )
"extra/project-euler/059/cipher1.txt" resource-path
ascii file-contents [ blank? ] right-trim "," split
[ string>number ] map ;
TUPLE: rollover seq n ;
C: <rollover> rollover
M: rollover length rollover-n ;
M: rollover nth-unsafe rollover-seq [ length mod ] keep nth-unsafe ;
INSTANCE: rollover immutable-sequence
: decrypt ( seq key -- seq )
over length <rollover> swap [ bitxor ] 2map ;
: frequency-analysis ( seq -- seq )
dup prune [
[ 2dup [ = ] curry count 2array , ] each
] { } make nip ; inline
: most-frequent ( seq -- elt )
frequency-analysis sort-values keys peek ;
: crack-key ( seq key-length -- key )
[ " " decrypt ] dip group 1 head-slice*
flip [ most-frequent ] map ;
PRIVATE>
: euler059 ( -- answer )
source-059 dup 3 crack-key decrypt sum ;
! [ euler059 ] 100 ave-time
! 13 ms run / 0 ms GC ave time - 100 trials
MAIN: euler059

1
extra/project-euler/059/cipher1.txt Normal file
View File

@ -0,0 +1 @@
79,59,12,2,79,35,8,28,20,2,3,68,8,9,68,45,0,12,9,67,68,4,7,5,23,27,1,21,79,85,78,79,85,71,38,10,71,27,12,2,79,6,2,8,13,9,1,13,9,8,68,19,7,1,71,56,11,21,11,68,6,3,22,2,14,0,30,79,1,31,6,23,19,10,0,73,79,44,2,79,19,6,28,68,16,6,16,15,79,35,8,11,72,71,14,10,3,79,12,2,79,19,6,28,68,32,0,0,73,79,86,71,39,1,71,24,5,20,79,13,9,79,16,15,10,68,5,10,3,14,1,10,14,1,3,71,24,13,19,7,68,32,0,0,73,79,87,71,39,1,71,12,22,2,14,16,2,11,68,2,25,1,21,22,16,15,6,10,0,79,16,15,10,22,2,79,13,20,65,68,41,0,16,15,6,10,0,79,1,31,6,23,19,28,68,19,7,5,19,79,12,2,79,0,14,11,10,64,27,68,10,14,15,2,65,68,83,79,40,14,9,1,71,6,16,20,10,8,1,79,19,6,28,68,14,1,68,15,6,9,75,79,5,9,11,68,19,7,13,20,79,8,14,9,1,71,8,13,17,10,23,71,3,13,0,7,16,71,27,11,71,10,18,2,29,29,8,1,1,73,79,81,71,59,12,2,79,8,14,8,12,19,79,23,15,6,10,2,28,68,19,7,22,8,26,3,15,79,16,15,10,68,3,14,22,12,1,1,20,28,72,71,14,10,3,79,16,15,10,68,3,14,22,12,1,1,20,28,68,4,14,10,71,1,1,17,10,22,71,10,28,19,6,10,0,26,13,20,7,68,14,27,74,71,89,68,32,0,0,71,28,1,9,27,68,45,0,12,9,79,16,15,10,68,37,14,20,19,6,23,19,79,83,71,27,11,71,27,1,11,3,68,2,25,1,21,22,11,9,10,68,6,13,11,18,27,68,19,7,1,71,3,13,0,7,16,71,28,11,71,27,12,6,27,68,2,25,1,21,22,11,9,10,68,10,6,3,15,27,68,5,10,8,14,10,18,2,79,6,2,12,5,18,28,1,71,0,2,71,7,13,20,79,16,2,28,16,14,2,11,9,22,74,71,87,68,45,0,12,9,79,12,14,2,23,2,3,2,71,24,5,20,79,10,8,27,68,19,7,1,71,3,13,0,7,16,92,79,12,2,79,19,6,28,68,8,1,8,30,79,5,71,24,13,19,1,1,20,28,68,19,0,68,19,7,1,71,3,13,0,7,16,73,79,93,71,59,12,2,79,11,9,10,68,16,7,11,71,6,23,71,27,12,2,79,16,21,26,1,71,3,13,0,7,16,75,79,19,15,0,68,0,6,18,2,28,68,11,6,3,15,27,68,19,0,68,2,25,1,21,22,11,9,10,72,71,24,5,20,79,3,8,6,10,0,79,16,8,79,7,8,2,1,71,6,10,19,0,68,19,7,1,71,24,11,21,3,0,73,79,85,87,79,38,18,27,68,6,3,16,15,0,17,0,7,68,19,7,1,71,24,11,21,3,0,71,24,5,20,79,9,6,11,1,71,27,12,21,0,17,0,7,68,15,6,9,75,79,16,15,10,68,16,0,22,11,11,68,3,6,0,9,72,16,71,29,1,4,0,3,9,6,30,2,79,12,14,2,68,16,7,1,9,79,12,2,79,7,6,2,1,73,79,85,86,79,33,17,10,10,71,6,10,71,7,13,20,79,11,16,1,68,11,14,10,3,79,5,9,11,68,6,2,11,9,8,68,15,6,23,71,0,19,9,79,20,2,0,20,11,10,72,71,7,1,71,24,5,20,79,10,8,27,68,6,12,7,2,31,16,2,11,74,71,94,86,71,45,17,19,79,16,8,79,5,11,3,68,16,7,11,71,13,1,11,6,1,17,10,0,71,7,13,10,79,5,9,11,68,6,12,7,2,31,16,2,11,68,15,6,9,75,79,12,2,79,3,6,25,1,71,27,12,2,79,22,14,8,12,19,79,16,8,79,6,2,12,11,10,10,68,4,7,13,11,11,22,2,1,68,8,9,68,32,0,0,73,79,85,84,79,48,15,10,29,71,14,22,2,79,22,2,13,11,21,1,69,71,59,12,14,28,68,14,28,68,9,0,16,71,14,68,23,7,29,20,6,7,6,3,68,5,6,22,19,7,68,21,10,23,18,3,16,14,1,3,71,9,22,8,2,68,15,26,9,6,1,68,23,14,23,20,6,11,9,79,11,21,79,20,11,14,10,75,79,16,15,6,23,71,29,1,5,6,22,19,7,68,4,0,9,2,28,68,1,29,11,10,79,35,8,11,74,86,91,68,52,0,68,19,7,1,71,56,11,21,11,68,5,10,7,6,2,1,71,7,17,10,14,10,71,14,10,3,79,8,14,25,1,3,79,12,2,29,1,71,0,10,71,10,5,21,27,12,71,14,9,8,1,3,71,26,23,73,79,44,2,79,19,6,28,68,1,26,8,11,79,11,1,79,17,9,9,5,14,3,13,9,8,68,11,0,18,2,79,5,9,11,68,1,14,13,19,7,2,18,3,10,2,28,23,73,79,37,9,11,68,16,10,68,15,14,18,2,79,23,2,10,10,71,7,13,20,79,3,11,0,22,30,67,68,19,7,1,71,8,8,8,29,29,71,0,2,71,27,12,2,79,11,9,3,29,71,60,11,9,79,11,1,79,16,15,10,68,33,14,16,15,10,22,73

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

@ -13,10 +13,11 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time
project-euler.033 project-euler.034 project-euler.035 project-euler.036
project-euler.037 project-euler.038 project-euler.039 project-euler.040
project-euler.041 project-euler.042 project-euler.043 project-euler.044
project-euler.045 project-euler.046 project-euler.048 project-euler.052
project-euler.053 project-euler.056 project-euler.067 project-euler.075
project-euler.079 project-euler.092 project-euler.097 project-euler.134
project-euler.169 project-euler.173 project-euler.175 ;
project-euler.045 project-euler.046 project-euler.047 project-euler.048
project-euler.052 project-euler.053 project-euler.056 project-euler.059
project-euler.067 project-euler.075 project-euler.079 project-euler.092
project-euler.097 project-euler.134 project-euler.169 project-euler.173
project-euler.175 ;
IN: project-euler
<PRIVATE

1
extra/rss/rss-tests.factor Normal file → Executable file
View File

@ -1,4 +1,5 @@
USING: rss io kernel io.files tools.test io.encodings.utf8 ;
IN: rss.tests
: load-news-file ( filename -- feed )
#! Load an news syndication file and process it, returning

16
extra/semantic-db/context/context.factor Normal file
View File

@ -0,0 +1,16 @@
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces semantic-db ;
IN: semantic-db.context
: create-context* ( context-name -- context-id ) create-node* ;
: create-context ( context-name -- ) create-context* drop ;
: context ( -- context-id )
\ context get ;
: set-context ( context-id -- )
\ context set ;
: with-context ( context-id quot -- )
>r \ context r> with-variable ;

44
extra/semantic-db/hierarchy/hierarchy.factor Normal file
View File

@ -0,0 +1,44 @@
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: accessors db.tuples kernel new-slots semantic-db semantic-db.relations sequences sequences.deep ;
IN: semantic-db.hierarchy
TUPLE: tree id children ;
C: <tree> tree
: has-parent-relation ( -- relation-id )
"has parent" relation-id ;
: parent-child* ( parent child -- arc-id )
has-parent-relation spin create-arc* ;
: parent-child ( parent child -- )
parent-child* drop ;
: un-parent-child ( parent child -- )
has-parent-relation spin <arc> select-tuples [ id>> delete-arc ] each ;
: child-arcs ( node-id -- child-arcs )
has-parent-relation f rot <arc> select-tuples ;
: children ( node-id -- children )
child-arcs [ subject>> ] map ;
: parent-arcs ( node-id -- parent-arcs )
has-parent-relation swap f <arc> select-tuples ;
: parents ( node-id -- parents )
parent-arcs [ object>> ] map ;
: get-node-hierarchy ( node-id -- tree )
dup children [ get-node-hierarchy ] map <tree> ;
: (get-root-nodes) ( node-id -- root-nodes/node-id )
dup parents dup empty? [
drop
] [
nip [ (get-root-nodes) ] map
] if ;
: get-root-nodes ( node-id -- root-nodes )
(get-root-nodes) flatten ;

26
extra/semantic-db/relations/relations.factor Normal file
View File

@ -0,0 +1,26 @@
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: db.types kernel namespaces semantic-db semantic-db.context
sequences.lib ;
IN: semantic-db.relations
! relations:
! - have a context in context 'semantic-db'
: create-relation* ( context-id relation-name -- relation-id )
create-node* tuck has-context-relation spin create-arc ;
: create-relation ( context-id relation-name -- )
create-relation* drop ;
: get-relation ( context-id relation-name -- relation-id/f )
[
":name" TEXT param ,
":context" INTEGER param ,
has-context-relation ":has_context" INTEGER param ,
] { } make
"select n.id from node n, arc a where n.content = :name and n.id = a.subject and a.relation = :has_context and a.object = :context"
single-int-results ?first ;
: relation-id ( relation-name -- relation-id )
context swap [ get-relation ] [ create-relation* ] ensure2 ;

58
extra/semantic-db/semantic-db-tests.factor Normal file
View File

@ -0,0 +1,58 @@
USING: accessors arrays db db.sqlite db.tuples kernel math namespaces
semantic-db semantic-db.context semantic-db.hierarchy semantic-db.relations
sequences tools.test tools.walker ;
IN: semantic-db.tests
[
create-node-table create-arc-table
[ 1 ] [ "first node" create-node* ] unit-test
[ 2 ] [ "second node" create-node* ] unit-test
[ 3 ] [ "third node" create-node* ] unit-test
[ 4 ] [ f create-node* ] unit-test
[ 5 ] [ 1 2 3 create-arc* ] unit-test
] with-tmp-sqlite
[
init-semantic-db
"test content" create-context* [
[ 4 ] [ context ] unit-test
[ 5 ] [ context "is test content" create-relation* ] unit-test
[ 5 ] [ context "is test content" get-relation ] unit-test
[ 5 ] [ "is test content" relation-id ] unit-test
[ 7 ] [ "has parent" relation-id ] unit-test
[ 7 ] [ "has parent" relation-id ] unit-test
[ "has parent" ] [ "has parent" relation-id node-content ] unit-test
[ "test content" ] [ context node-content ] unit-test
] with-context
! type-type 1array [ "type" ensure-type ] unit-test
! [ { 1 2 3 } ] [ type-type select-nodes-of-type ] unit-test
! [ 1 ] [ type-type select-node-of-type ] unit-test
! [ t ] [ "content" ensure-type integer? ] unit-test
! [ t ] [ "content" ensure-type "content" ensure-type = ] unit-test
! [ t ] [ "content" ensure-type "first content" create-node-of-type integer? ] unit-test
! [ t ] [ "content" ensure-type select-node-of-type integer? ] unit-test
! [ t ] [ "content" ensure-type "first content" select-node-of-type-with-content integer? ] unit-test
! [ t ] [ "content" ensure-type "first content" ensure-node-of-type integer? ] unit-test
! [ t ] [ "content" ensure-type "second content" ensure-node-of-type integer? ] unit-test
! [ 2 ] [ "content" ensure-type select-nodes-of-type length ] unit-test
] with-tmp-sqlite
! test hierarchy
[
init-semantic-db
"family tree" create-context* [
"adam" create-node* "adam" set
"eve" create-node* "eve" set
"bob" create-node* "bob" set
"fran" create-node* "fran" set
"charlie" create-node* "charlie" set
"gertrude" create-node* "gertrude" set
[ t ] [ "adam" get "bob" get parent-child* integer? ] unit-test
{ { "eve" "bob" } { "eve" "fran" } { "bob" "gertrude" } { "bob" "fran" } { "fran" "charlie" } } [ first2 [ get ] 2apply parent-child ] each
[ { "bob" "fran" } ] [ "eve" get children [ node-content ] map ] unit-test
[ { "adam" "eve" } ] [ "bob" get parents [ node-content ] map ] unit-test
[ "fran" { "charlie" } ] [ "fran" get get-node-hierarchy dup tree-id node-content swap tree-children [ tree-id node-content ] map ] unit-test
[ { "adam" "eve" } ] [ "charlie" get break get-root-nodes [ node-content ] map ] unit-test
[ { } ] [ "fran" get "charlie" get tuck un-parent-child parents [ node-content ] map ] unit-test
] with-context
] with-tmp-sqlite

Some files were not shown because too many files have changed in this diff Show More