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

Merge branch 'master' into trace_tool

db4
Slava Pestov 2009-04-14 20:42:02 -05:00
parent 59e0434815 da38a25963
commit 5daf19afa2
106 changed files with 1739 additions and 1307 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
basis/base64/base64-tests.factor
View File

@ -23,5 +23,8 @@ IN: base64.tests
ascii encode >base64-lines >string
] unit-test
[ { 33 52 17 40 12 51 33 43 18 33 23 } base64> ]
[ malformed-base64? ] must-fail-with
\ >base64 must-infer
\ base64> must-infer

6
basis/base64/base64.factor
View File

@ -5,6 +5,8 @@ io.streams.byte-array kernel math namespaces
sequences strings io.crlf ;
IN: base64
ERROR: malformed-base64 ;
<PRIVATE
: read1-ignoring ( ignoring -- ch )
@ -25,7 +27,7 @@ IN: base64
f 0 f f f 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21
22 23 24 25 f f f f f f 26 27 28 29 30 31 32 33 34 35 36 37 38 39
40 41 42 43 44 45 46 47 48 49 50 51
} nth ; inline
} nth [ malformed-base64 ] unless* ; inline
SYMBOL: column
@ -48,8 +50,6 @@ SYMBOL: column
[ 3 0 pad-tail binary [ encode3 ] with-byte-writer ]
[ 1+ ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline
ERROR: malformed-base64 ;
: decode4 ( seq -- )
[ 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ]
[ [ CHAR: = = ] count ] bi head-slice*

4
basis/compiler/tree/propagation/recursive/recursive.factor
View File

@ -28,8 +28,8 @@ IN: compiler.tree.propagation.recursive
{
{ [ 2dup interval-subset? ] [ empty-interval ] }
{ [ over empty-interval eq? ] [ empty-interval ] }
{ [ 2dup interval>= t eq? ] [ 1./0. [a,a] ] }
{ [ 2dup interval<= t eq? ] [ -1./0. [a,a] ] }
{ [ 2dup interval>= t eq? ] [ 1/0. [a,a] ] }
{ [ 2dup interval<= t eq? ] [ -1/0. [a,a] ] }
[ [-inf,inf] ]
} cond interval-union nip ;

5
basis/db/queries/queries.factor
View File

@ -4,7 +4,7 @@ USING: accessors kernel math namespaces make sequences random
strings math.parser math.intervals combinators math.bitwise
nmake db db.tuples db.types classes words shuffle arrays
destructors continuations db.tuples.private prettyprint
db.private ;
db.private byte-arrays ;
IN: db.queries
GENERIC: where ( specs obj -- )
@ -115,6 +115,9 @@ M: sequence where ( spec obj -- )
[ " or " 0% ] [ dupd where ] interleave drop
] in-parens ;
M: byte-array where ( spec obj -- )
over column-name>> 0% " = " 0% bind# ;
M: NULL where ( spec obj -- )
drop column-name>> 0% " is NULL" 0% ;

25
basis/db/tuples/tuples-tests.factor
View File

@ -411,7 +411,7 @@ TUPLE: exam id name score ;
T{ exam f 4 "Cartman" 41 }
}
] [
T{ exam f T{ interval f { 2 t } { 1.0/0.0 f } } } select-tuples
T{ exam f T{ interval f { 2 t } { 1/0. f } } } select-tuples
] unit-test
[
@ -419,7 +419,7 @@ TUPLE: exam id name score ;
T{ exam f 1 "Kyle" 100 }
}
] [
T{ exam f T{ interval f { -1.0/0.0 t } { 2 f } } } select-tuples
T{ exam f T{ interval f { -1/0. t } { 2 f } } } select-tuples
] unit-test
[
@ -430,7 +430,7 @@ TUPLE: exam id name score ;
T{ exam f 4 "Cartman" 41 }
}
] [
T{ exam f T{ interval f { -1.0/0.0 t } { 1/0. f } } } select-tuples
T{ exam f T{ interval f { -1/0. t } { 1/0. f } } } select-tuples
] unit-test
[
@ -634,3 +634,22 @@ compound-foo "COMPOUND_FOO"
[ test-compound-primary-key ] test-sqlite
[ test-compound-primary-key ] test-postgresql
TUPLE: example id data ;
example "EXAMPLE"
{
{ "id" "ID" +db-assigned-id+ }
{ "data" "DATA" BLOB }
} define-persistent
: test-blob-select ( -- )
example ensure-table
[ ] [ example new B{ 1 2 3 4 5 } >>data insert-tuple ] unit-test
[
T{ example { id 1 } { data B{ 1 2 3 4 5 } } }
] [ example new B{ 1 2 3 4 5 } >>data select-tuple ] unit-test ;
[ test-blob-select ] test-sqlite
[ test-blob-select ] test-postgresql

2
basis/furnace/cache/cache.factor vendored
View File

@ -22,7 +22,7 @@ server-state f
: expire-state ( class -- )
new
-1.0/0.0 millis [a,b] >>expires
-1/0. millis [a,b] >>expires
delete-tuples ;
TUPLE: server-state-manager < filter-responder timeout ;

2
basis/help/handbook/handbook.factor
View File

@ -49,6 +49,7 @@ $nl
{ "associative mapping" { "an object whose class implements the " { $link "assocs-protocol" } } }
{ "boolean" { { $link t } " or " { $link f } } }
{ "class" { "a set of objects identified by a " { $emphasis "class word" } " together with a discriminating predicate. See " { $link "classes" } } }
{ "combinator" { "a word taking a quotation or another word as input; a higher-order function. See " { $link "combinators" } } }
{ "definition specifier" { "an instance of " { $link definition } " which implements the " { $link "definition-protocol" } } }
{ "generalized boolean" { "an object interpreted as a boolean; a value of " { $link f } " denotes false and anything else denotes true" } }
{ "generic word" { "a word whose behavior depends can be specialized on the class of one of its inputs. See " { $link "generic" } } }
@ -56,6 +57,7 @@ $nl
{ "object" { "any datum which can be identified" } }
{ "ordering specifier" { "see " { $link "order-specifiers" } } }
{ "pathname string" { "an OS-specific pathname which identifies a file" } }
{ "quotation" { "an anonymous function; an instance of the " { $link quotation } " class. More generally, instances of the " { $link callable } " class can be used in many places documented to expect quotations" } }
{ "sequence" { "a sequence; see " { $link "sequence-protocol" } } }
{ "slot" { "a component of an object which can store a value" } }
{ "stack effect" { "a pictorial representation of a word's inputs and outputs, for example " { $snippet "+ ( x y -- z )" } ". See " { $link "effects" } } }

4
basis/hints/hints.factor
View File

@ -3,7 +3,7 @@
USING: parser words definitions kernel sequences assocs arrays
kernel.private fry combinators accessors vectors strings sbufs
byte-arrays byte-vectors io.binary io.streams.string splitting
math generic generic.standard generic.standard.engines classes
math math.parser generic generic.standard generic.standard.engines classes
hashtables ;
IN: hints
@ -118,6 +118,8 @@ SYNTAX: HINTS:
\ >be { { bignum fixnum } { fixnum fixnum } } "specializer" set-word-prop
\ base> { string fixnum } "specializer" set-word-prop
M\ hashtable at* { { fixnum object } { word object } } "specializer" set-word-prop
M\ hashtable set-at { { object fixnum object } { object word object } } "specializer" set-word-prop

2
basis/http/client/client.factor
View File

@ -165,7 +165,7 @@ ERROR: download-failed response ;
present file-name "?" split1 drop "/" ?tail drop ;
: download-to ( url file -- )
binary [ [ write ] with-http-get drop ] with-file-writer ;
binary [ [ write ] with-http-get check-response drop ] with-file-writer ;
: download ( url -- )
dup download-name download-to ;

9
basis/http/http-tests.factor
View File

@ -392,4 +392,11 @@ SYMBOL: a
[ "OK" ] [ "data" "http://localhost/a" add-port http-post nip ] unit-test
[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test
! Check that download throws errors (reported by Chris Double)
[
"resource:temp" [
"http://localhost/tweet_my_twat" add-port download
] with-directory
] must-fail
[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test

37
basis/images/bitmap/bitmap-tests.factor
View File

@ -1,6 +1,7 @@
USING: images.bitmap images.viewer io.encodings.binary
io.files io.files.unique kernel tools.test images.loader
literals sequences ;
literals sequences checksums.md5 checksums
images.normalization ;
IN: images.bitmap.tests
CONSTANT: test-bitmap24 "vocab:images/test-images/thiswayup24.bmp"
@ -11,17 +12,33 @@ CONSTANT: test-bitmap4 "vocab:images/test-images/rgb4bit.bmp"
CONSTANT: test-bitmap1 "vocab:images/test-images/1bit.bmp"
[ t ]
[
test-bitmap24
[ binary file-contents ] [ load-image ] bi
"test-bitmap24" unique-file
[ save-bitmap ] [ binary file-contents ] bi =
] unit-test
CONSTANT: test-40 "vocab:images/test-images/40red24bit.bmp"
CONSTANT: test-41 "vocab:images/test-images/41red24bit.bmp"
CONSTANT: test-42 "vocab:images/test-images/42red24bit.bmp"
CONSTANT: test-43 "vocab:images/test-images/43red24bit.bmp"
{
$ test-bitmap8
$ test-bitmap24
"vocab:ui/render/test/reference.bmp"
} [ [ ] swap [ load-image drop ] curry unit-test ] each
} [ [ ] swap [ load-image drop ] curry unit-test ] each
: test-bitmap-save ( path -- ? )
[ md5 checksum-file ]
[ load-image normalize-image ] bi
"bitmap-save-test" unique-file
[ save-bitmap ]
[ md5 checksum-file ] bi = ;
[
t
] [
{
$ test-40
$ test-41
$ test-42
$ test-43
$ test-bitmap24
} [ test-bitmap-save ] all?
] unit-test

60
basis/images/bitmap/bitmap.factor
View File

@ -37,14 +37,14 @@ M: bitmap-magic summary
ERROR: bmp-not-supported n ;
: reverse-lines ( byte-array width -- byte-array )
3 * <sliced-groups> <reversed> concat ; inline
<sliced-groups> <reversed> concat ; inline
: raw-bitmap>seq ( loading-bitmap -- array )
dup bit-count>>
{
{ 32 [ color-index>> ] }
{ 24 [ [ color-index>> ] [ width>> ] bi reverse-lines ] }
{ 8 [ [ 8bit>buffer ] [ width>> ] bi reverse-lines ] }
{ 24 [ [ color-index>> ] [ width>> 3 * ] bi reverse-lines ] }
{ 8 [ [ 8bit>buffer ] [ width>> 3 * ] bi reverse-lines ] }
[ bmp-not-supported ]
} case >byte-array ;
@ -81,30 +81,31 @@ ERROR: bmp-not-supported n ;
: image-size ( loading-bitmap -- n )
[ [ width>> ] [ height>> ] bi * ] [ bit-count>> 8 /i ] bi * abs ;
: bitmap-padding ( width -- n )
3 * 4 mod 4 swap - 4 mod ; inline
:: fixup-color-index ( loading-bitmap -- loading-bitmap )
loading-bitmap width>> :> width
width 3 * :> width*3
loading-bitmap height>> abs :> height
loading-bitmap color-index>> length :> color-index-length
color-index-length height /i :> stride
color-index-length width*3 height * - height /i :> padding
loading-bitmap width>> bitmap-padding :> padding
loading-bitmap [ color-index>> length ] [ height>> abs ] bi /i :> stride
loading-bitmap
padding 0 > [
loading-bitmap [
[
stride <sliced-groups>
[ width*3 head-slice ] map concat
] change-color-index
] [
loading-bitmap
] if ;
] when ;
: parse-bitmap ( loading-bitmap -- loading-bitmap )
dup rgb-quads-length read >>rgb-quads
dup color-index-length read >>color-index
fixup-color-index ;
: load-bitmap-data ( path loading-bitmap -- loading-bitmap )
[ binary ] dip '[
_ parse-file-header parse-bitmap-header parse-bitmap
: load-bitmap-data ( path -- loading-bitmap )
binary [
loading-bitmap new
parse-file-header parse-bitmap-header parse-bitmap
] with-file-reader ;
ERROR: unknown-component-order bitmap ;
@ -117,8 +118,7 @@ ERROR: unknown-component-order bitmap ;
[ unknown-component-order ]
} case ;
: loading-bitmap>bitmap-image ( loading-bitmap -- bitmap-image )
[ bitmap-image new ] dip
: loading-bitmap>bitmap-image ( bitmap-image loading-bitmap -- bitmap-image )
{
[ raw-bitmap>seq >>bitmap ]
[ [ width>> ] [ height>> abs ] bi 2array >>dim ]
@ -127,20 +127,30 @@ ERROR: unknown-component-order bitmap ;
} cleave ;
M: bitmap-image load-image* ( path loading-bitmap -- bitmap )
drop loading-bitmap new
load-bitmap-data
loading-bitmap>bitmap-image ;
swap load-bitmap-data loading-bitmap>bitmap-image ;
PRIVATE>
: bitmap>color-index ( bitmap-array -- byte-array )
4 <sliced-groups> [ 3 head-slice <reversed> ] map B{ } join ; inline
: bitmap>color-index ( bitmap -- byte-array )
[
bitmap>>
4 <sliced-groups>
[ 3 head-slice <reversed> ] map
B{ } join
] [
dim>> first dup bitmap-padding dup 0 > [
[ 3 * group ] dip '[ _ <byte-array> append ] map
B{ } join
] [
2drop
] if
] bi ;
: save-bitmap ( image path -- )
binary [
B{ CHAR: B CHAR: M } write
[
bitmap>> bitmap>color-index length 14 + 40 + write4
bitmap>color-index length 14 + 40 + write4
0 write4
54 write4
40 write4
@ -159,7 +169,7 @@ PRIVATE>
[ drop 0 write4 ]
! size-image
[ bitmap>> bitmap>color-index length write4 ]
[ bitmap>color-index length write4 ]
! x-pels
[ drop 0 write4 ]
@ -175,7 +185,9 @@ PRIVATE>
! rgb-quads
[
[ bitmap>> bitmap>color-index ] [ dim>> first ] bi
[ bitmap>color-index ]
[ dim>> first 3 * ]
[ dim>> first bitmap-padding + ] tri
reverse-lines write
]
} cleave

5
basis/images/images.factor
View File

@ -3,7 +3,7 @@
USING: combinators kernel accessors ;
IN: images
SINGLETONS: L BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
SINGLETONS: L LA BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ;
UNION: alpha-channel BGRA RGBA ABGR ARGB R16G16B16A16 R32G32B32A32 ;
@ -11,6 +11,7 @@ UNION: alpha-channel BGRA RGBA ABGR ARGB R16G16B16A16 R32G32B32A32 ;
: bytes-per-pixel ( component-order -- n )
{
{ L [ 1 ] }
{ LA [ 2 ] }
{ BGR [ 3 ] }
{ RGB [ 3 ] }
{ BGRA [ 4 ] }
@ -33,4 +34,4 @@ TUPLE: image dim component-order upside-down? bitmap ;
: has-alpha? ( image -- ? ) component-order>> alpha-channel? ;
GENERIC: load-image* ( path tuple -- image )
GENERIC: load-image* ( path tuple -- image )

5
basis/images/loader/loader.factor
View File

@ -1,8 +1,7 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: constructors kernel splitting unicode.case combinators
accessors images.bitmap images.tiff images images.normalization
io.pathnames ;
accessors images.bitmap images.tiff images io.pathnames ;
IN: images.loader
ERROR: unknown-image-extension extension ;
@ -16,4 +15,4 @@ ERROR: unknown-image-extension extension ;
} case ;
: load-image ( path -- image )
dup image-class new load-image* normalize-image ;
dup image-class new load-image* ;

3
basis/images/tiff/tiff.factor
View File

@ -463,6 +463,7 @@ ERROR: unknown-component-order ifd ;
{ { 16 16 16 } [ 2 seq>native-endianness ] }
{ { 8 8 8 8 } [ ] }
{ { 8 8 8 } [ ] }
{ 8 [ ] }
[ unknown-component-order ]
} case >>bitmap ;
@ -474,11 +475,11 @@ ERROR: unknown-component-order ifd ;
{ { 16 16 16 } [ R16G16B16 ] }
{ { 8 8 8 8 } [ RGBA ] }
{ { 8 8 8 } [ RGB ] }
{ 8 [ LA ] }
[ unknown-component-order ]
} case ;
: normalize-alpha-data ( seq -- byte-array )
! [ normalize-alpha-data ] change-bitmap
B{ } like dup
byte-array>float-array
4 <sliced-groups>

2
basis/io/files/unique/unique-docs.factor
View File

@ -62,8 +62,8 @@ HELP: current-temporary-directory
HELP: unique-file
{ $values
{ "prefix" string }
{ "path" "a pathname string" }
{ "path'" "a pathname string" }
}
{ $description "Creates a temporary file in the directory stored in " { $link current-temporary-directory } " and outputs the path name." } ;

2
basis/io/files/unique/unique.factor
View File

@ -64,7 +64,7 @@ PRIVATE>
[ unique-directory ] dip
'[ _ with-temporary-directory ] [ delete-tree ] bi ; inline
: unique-file ( path -- path' )
: unique-file ( prefix -- path )
"" make-unique-file ;
{

2
basis/lcs/lcs.factor
View File

@ -8,7 +8,7 @@ IN: lcs
0 1 ? + [ [ 1+ ] bi@ ] dip min min ;
: lcs-step ( insert delete change same? -- next )
1 -1./0. ? + max max ; ! -1./0. is -inf (float)
1 -1/0. ? + max max ; ! -1/0. is -inf (float)
:: loop-step ( i j matrix old new step -- )
i j 1+ matrix nth nth ! insertion

4
basis/math/functions/functions-tests.factor
View File

@ -22,9 +22,9 @@ IN: math.functions.tests
[ t ] [ e pi i* ^ imaginary-part -0.00001 0.00001 between? ] unit-test
[ t ] [ 0 0 ^ fp-nan? ] unit-test
[ 1.0/0.0 ] [ 0 -2 ^ ] unit-test
[ 1/0. ] [ 0 -2 ^ ] unit-test
[ t ] [ 0 0.0 ^ fp-nan? ] unit-test
[ 1.0/0.0 ] [ 0 -2.0 ^ ] unit-test
[ 1/0. ] [ 0 -2.0 ^ ] unit-test
[ 0 ] [ 0 3.0 ^ ] unit-test
[ 0 ] [ 0 3 ^ ] unit-test

2
basis/math/functions/functions.factor
View File

@ -81,7 +81,7 @@ PRIVATE>
2dup [ real? ] both? [ drop 0 >= ] [ 2drop f ] if ; inline
: 0^ ( x -- z )
dup zero? [ drop 0./0. ] [ 0 < 1./0. 0 ? ] if ; inline
dup zero? [ drop 0/0. ] [ 0 < 1/0. 0 ? ] if ; inline
: (^mod) ( n x y -- z )
make-bits 1 [

8
basis/math/intervals/intervals.factor
View File

@ -40,13 +40,13 @@ TUPLE: interval { from read-only } { to read-only } ;
: [a,a] ( a -- interval )
closed-point dup <interval> ; foldable
: [-inf,a] ( a -- interval ) -1./0. swap [a,b] ; inline
: [-inf,a] ( a -- interval ) -1/0. swap [a,b] ; inline
: [-inf,a) ( a -- interval ) -1./0. swap [a,b) ; inline
: [-inf,a) ( a -- interval ) -1/0. swap [a,b) ; inline
: [a,inf] ( a -- interval ) 1./0. [a,b] ; inline
: [a,inf] ( a -- interval ) 1/0. [a,b] ; inline
: (a,inf] ( a -- interval ) 1./0. (a,b] ; inline
: (a,inf] ( a -- interval ) 1/0. (a,b] ; inline
: [-inf,inf] ( -- interval ) full-interval ; inline

2
basis/math/libm/libm-docs.factor
View File

@ -6,7 +6,7 @@ ARTICLE: "math.libm" "C standard library math functions"
$nl
"They can be called directly, however there is little reason to do so, since they only implement real-valued functions, and in some cases place restrictions on the domain:"
{ $example "USE: math.functions" "2 acos ." "C{ 0.0 1.316957896924817 }" }
{ $unchecked-example "USE: math.libm" "2 facos ." "0.0/0.0" }
{ $unchecked-example "USE: math.libm" "2 facos ." "0/0." }
"Trigonometric functions:"
{ $subsection fcos }
{ $subsection fsin }

1
basis/opengl/authors.txt
View File

@ -1,3 +1,4 @@
Slava Pestov
Eduardo Cavazos
Joe Groff
Alex Chapman

2
basis/opengl/capabilities/capabilities.factor
View File

@ -32,6 +32,8 @@ IN: opengl.capabilities
(gl-version) drop ;
: gl-vendor-version ( -- version )
(gl-version) nip ;
: gl-vendor ( -- name )
GL_VENDOR glGetString ;
: has-gl-version? ( version -- ? )
gl-version version-before? ;
: (make-gl-version-error) ( required-version -- )

2
basis/opengl/gl/authors.txt
View File

@ -1 +1 @@
Slava Pestov
Alex Chapman

1
basis/opengl/glu/authors.txt
View File

@ -1 +0,0 @@
Slava Pestov

24
basis/opengl/opengl.factor
View File

@ -3,7 +3,7 @@
! Portions copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types continuations kernel libc math macros
namespaces math.vectors math.parser opengl.gl opengl.glu combinators
namespaces math.vectors math.parser opengl.gl combinators
combinators.smart arrays sequences splitting words byte-arrays assocs
colors colors.constants accessors generalizations locals fry
specialized-arrays.float specialized-arrays.uint ;
@ -16,10 +16,23 @@ IN: opengl
: gl-clear ( color -- )
gl-clear-color GL_COLOR_BUFFER_BIT glClear ;
: error>string ( n -- string )
H{
{ HEX: 0 "No error" }
{ HEX: 0501 "Invalid value" }
{ HEX: 0500 "Invalid enumerant" }
{ HEX: 0502 "Invalid operation" }
{ HEX: 0503 "Stack overflow" }
{ HEX: 0504 "Stack underflow" }
{ HEX: 0505 "Out of memory" }
} at "Unknown error" or ;
TUPLE: gl-error code string ;
: gl-error ( -- )
glGetError dup zero? [
"GL error: " over gluErrorString append throw
] unless drop ;
glGetError dup 0 = [ drop ] [
dup error>string \ gl-error boa throw
] if ;
: do-enabled ( what quot -- )
over glEnable dip glDisable ; inline
@ -151,9 +164,6 @@ MACRO: all-enabled-client-state ( seq quot -- )
MACRO: set-draw-buffers ( buffers -- )
words>values '[ _ (set-draw-buffers) ] ;
: gl-look-at ( eye focus up -- )
[ first3 ] tri@ gluLookAt ;
: gen-dlist ( -- id ) 1 glGenLists ;
: make-dlist ( type quot -- id )

34
basis/opengl/textures/textures.factor
View File

@ -1,13 +1,23 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs cache colors.constants destructors fry kernel
opengl opengl.gl combinators images images.tesselation grouping
specialized-arrays.float sequences math math.vectors
math.matrices generalizations fry arrays namespaces ;
opengl opengl.gl opengl.capabilities combinators images
images.tesselation grouping specialized-arrays.float sequences math
math.vectors math.matrices generalizations fry arrays namespaces
system ;
IN: opengl.textures
SYMBOL: non-power-of-2-textures?
: check-extensions ( -- )
#! ATI frglx driver doesn't implement GL_ARB_texture_non_power_of_two properly.
#! See thread 'Linux font display problem' April 2009 on Factor-talk
gl-vendor "ATI Technologies Inc." = not os macosx? or [
"2.0" { "GL_ARB_texture_non_power_of_two" }
has-gl-version-or-extensions?
non-power-of-2-textures? set
] when ;
: gen-texture ( -- id ) [ glGenTextures ] (gen-gl-object) ;
: delete-texture ( id -- ) [ glDeleteTextures ] (delete-gl-object) ;
@ -20,6 +30,8 @@ M: RGBA component-order>format drop GL_RGBA GL_UNSIGNED_BYTE ;
M: ARGB component-order>format drop GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8_REV ;
M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
M: BGRX component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
M: LA component-order>format drop GL_LUMINANCE_ALPHA GL_UNSIGNED_BYTE ;
M: L component-order>format drop GL_LUMINANCE GL_UNSIGNED_BYTE ;
SLOT: display-list
@ -36,10 +48,12 @@ TUPLE: single-texture image dim loc texture-coords texture display-list disposed
[ next-power-of-2 ] map
] unless ;
: (tex-image) ( image -- )
[ GL_TEXTURE_2D 0 GL_RGBA ] dip
[ dim>> adjust-texture-dim first2 0 ]
[ component-order>> component-order>format f ] bi
: (tex-image) ( image bitmap -- )
[
[ GL_TEXTURE_2D 0 GL_RGBA ] dip
[ dim>> adjust-texture-dim first2 0 ]
[ component-order>> component-order>format ] bi
] dip
glTexImage2D ;
: (tex-sub-image) ( image -- )
@ -53,7 +67,9 @@ TUPLE: single-texture image dim loc texture-coords texture display-list disposed
gen-texture [
GL_TEXTURE_BIT [
GL_TEXTURE_2D swap glBindTexture
[ (tex-image) ] [ (tex-sub-image) ] bi
non-power-of-2-textures? get
[ dup bitmap>> (tex-image) ]
[ [ f (tex-image) ] [ (tex-sub-image) ] bi ] if
] do-attribs
] keep ;
@ -159,4 +175,4 @@ PRIVATE>
: <texture> ( image loc -- texture )
over dim>> max-texture-size [ <= ] 2all?
[ <single-texture> ]
[ [ max-texture-size tesselate ] dip <multi-texture> ] if ;
[ [ max-texture-size tesselate ] dip <multi-texture> ] if ;

6
basis/pango/layouts/layouts.factor
View File

@ -44,7 +44,7 @@ FUNCTION: PangoLayoutLine*
pango_layout_get_line_readonly ( PangoLayout* layout, int line ) ;
FUNCTION: void
pango_layout_line_index_to_x ( PangoLayoutLine* line, int index_, gboolean trailing, int* x_pos ) ;
pango_layout_line_index_to_x ( PangoLayoutLine* line, int index_, uint trailing, int* x_pos ) ;
FUNCTION: gboolean
pango_layout_line_x_to_index ( PangoLayoutLine* line, int x_pos, int* index_, int* trailing ) ;
@ -122,7 +122,7 @@ MEMO: missing-font-metrics ( font -- metrics )
: line-offset>x ( layout n -- x )
#! n is an index into the UTF8 encoding of the text
[ drop first-line ] [ swap string>> >utf8-index ] 2bi
f 0 <int> [ pango_layout_line_index_to_x ] keep
0 0 <int> [ pango_layout_line_index_to_x ] keep
*int pango>float ;
: x>line-offset ( layout x -- n )
@ -205,4 +205,4 @@ SYMBOL: cached-layouts
: cached-line ( font string -- line )
cached-layout layout>> first-line ;
[ <cache-assoc> cached-layouts set-global ] "pango.layouts" add-init-hook
[ <cache-assoc> cached-layouts set-global ] "pango.layouts" add-init-hook

4
basis/regexp/parser/parser.factor
View File

@ -102,8 +102,10 @@ MEMO: simple-category-table ( -- table )
{ CHAR: s dotall }
} ;
ERROR: nonexistent-option name ;
: ch>option ( ch -- singleton )
options-assoc at ;
dup options-assoc at [ ] [ nonexistent-option ] ?if ;
: option>ch ( option -- string )
options-assoc value-at ;

86
basis/stack-checker/transforms/transforms.factor
View File

@ -1,13 +1,13 @@
! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors arrays kernel kernel.private combinators.private
words sequences generic math math.order namespaces make quotations assocs
combinators combinators.short-circuit classes.tuple
words sequences generic math math.order namespaces make quotations
assocs combinators combinators.short-circuit classes.tuple
classes.tuple.private effects summary hashtables classes generic sets
definitions generic.standard slots.private continuations locals
generalizations stack-checker.backend stack-checker.state
stack-checker.visitor stack-checker.errors stack-checker.values
stack-checker.recursive-state ;
sequences.private generalizations stack-checker.backend
stack-checker.state stack-checker.visitor stack-checker.errors
stack-checker.values stack-checker.recursive-state ;
IN: stack-checker.transforms
: give-up-transform ( word -- )
@ -106,40 +106,68 @@ IN: stack-checker.transforms
] [ drop f ] if
] 1 define-transform
! Membership testing
CONSTANT: bit-member-max 256
! Fast at for integer maps
CONSTANT: lookup-table-at-max 256
: bit-member? ( seq -- ? )
: lookup-table-at? ( assoc -- ? )
#! Can we use a fast byte array test here?
{
[ length 4 > ]
[ [ integer? ] all? ]
[ [ 0 bit-member-max between? ] any? ]
[ assoc-size 4 > ]
[ values [ ] all? ]
[ keys [ integer? ] all? ]
[ keys [ 0 lookup-table-at-max between? ] all? ]
} 1&& ;
: bit-member-seq ( seq -- flags )
[ supremum 1+ ] keep '[ _ member? 1 0 ? ] B{ } map-as ;
: lookup-table-seq ( assoc -- table )
[ keys supremum 1+ ] keep '[ _ at ] { } map-as ;
: bit-member-quot ( seq -- newquot )
bit-member-seq
: lookup-table-quot ( seq -- newquot )
lookup-table-seq
'[
_ {
{ [ over fixnum? ] [ ?nth 1 eq? ] }
{ [ over bignum? ] [ ?nth 1 eq? ] }
[ 2drop f ]
} cond
_ over integer? [
2dup bounds-check? [
nth-unsafe dup >boolean
] [ 2drop f f ] if
] [ 2drop f f ] if
] ;
: member-quot ( seq -- newquot )
dup bit-member? [
bit-member-quot
] [
dup length 4 <= [
[ drop f ] swap
[ literalize [ t ] ] { } map>assoc linear-case-quot
: fast-lookup-table-at? ( assoc -- ? )
values {
[ [ integer? ] all? ]
[ [ 0 254 between? ] all? ]
} 1&& ;
: fast-lookup-table-seq ( assoc -- table )
lookup-table-seq [ 255 or ] B{ } map-as ;
: fast-lookup-table-quot ( seq -- newquot )
fast-lookup-table-seq
'[
_ over integer? [
2dup bounds-check? [
nth-unsafe dup 255 eq? [ drop f f ] [ t ] if
] [ 2drop f f ] if
] [ 2drop f f ] if
] ;
: at-quot ( assoc -- quot )
dup lookup-table-at? [
dup fast-lookup-table-at? [
fast-lookup-table-quot
] [
unique [ key? ] curry
lookup-table-quot
] if
] [ drop f ] if ;
\ at* [ at-quot ] 1 define-transform
! Membership testing
: member-quot ( seq -- newquot )
dup length 4 <= [
[ drop f ] swap
[ literalize [ t ] ] { } map>assoc linear-case-quot
] [
unique [ key? ] curry
] if ;
\ member? [
@ -170,4 +198,4 @@ CONSTANT: bit-member-max 256
\ shuffle [
shuffle-mapping nths-quot
] 1 define-transform
] 1 define-transform

5
basis/tools/hexdump/hexdump.factor
View File

@ -16,10 +16,11 @@ IN: tools.hexdump
16 * >hex 8 CHAR: 0 pad-head write "h: " write ;
: >hex-digit ( digit -- str )
>hex 2 CHAR: 0 pad-head " " append ;
>hex 2 CHAR: 0 pad-head ;
: >hex-digits ( bytes -- str )
[ >hex-digit ] { } map-as concat 48 CHAR: \s pad-tail ;
[ >hex-digit " " append ] { } map-as concat
48 CHAR: \s pad-tail ;
: >ascii ( bytes -- str )
[ [ printable? ] keep CHAR: . ? ] "" map-as ;

11
basis/ui/backend/cocoa/cocoa.factor
View File

@ -39,13 +39,16 @@ M: pasteboard set-clipboard-contents
[ 0 0 ] dip dim>> first2 <CGRect> ;
: auto-position ( window loc -- )
#! Note: if this is the initial window, the length of the windows
#! vector should be 1, since (open-window) calls auto-position
#! after register-window.
dup { 0 0 } = [
drop
windows get [ -> center ] [
peek second window-loc>>
windows get length 1 <= [ -> center ] [
windows get peek second window-loc>>
dupd first2 <CGPoint> -> cascadeTopLeftFromPoint:
-> setFrameTopLeftPoint:
] if-empty
] if
] [ first2 <CGPoint> -> setFrameTopLeftPoint: ] if ;
M: cocoa-ui-backend set-title ( string world -- )
@ -70,8 +73,8 @@ M:: cocoa-ui-backend (open-window) ( world -- )
world dim>> <FactorView> :> view
view world world>NSRect <ViewWindow> :> window
view -> release
window world window-loc>> auto-position
world view register-window
window world window-loc>> auto-position
world window save-position
window install-window-delegate
view window <window-handle> world (>>handle)

2
basis/ui/backend/cocoa/views/views.factor
View File

@ -336,7 +336,7 @@ CLASS: {
! Initialization
{ "updateFactorGadgetSize:" "void" { "id" "SEL" "id" }
[ 2drop dup view-dim swap window (>>dim) yield ]
[ 2drop [ window ] [ view-dim ] bi >>dim drop yield ]
}
{ "doCommandBySelector:" "void" { "id" "SEL" "SEL" }

12
basis/ui/backend/x11/x11.factor
View File

@ -224,6 +224,10 @@ M: x-clipboard paste-clipboard
[ XA_NET_WM_NAME XA_UTF8_STRING 8 PropModeReplace ] dip
utf8 encode dup length XChangeProperty drop ;
: set-class ( dpy window -- )
XA_WM_CLASS XA_UTF8_STRING 8 PropModeReplace "Factor"
utf8 encode dup length XChangeProperty drop ;
M: x11-ui-backend set-title ( string world -- )
handle>> window>> swap
[ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ;
@ -242,11 +246,15 @@ M: x11-ui-backend set-fullscreen* ( ? world -- )
M: x11-ui-backend (open-window) ( world -- )
dup gadget-window
handle>> window>> dup set-closable map-window ;
handle>> window>>
[ set-closable ] [ dpy get swap set-class ] [ map-window ] tri ;
M: x11-ui-backend raise-window* ( world -- )
handle>> [
dpy get swap window>> XRaiseWindow drop
dpy get swap window>>
[ RevertToPointerRoot CurrentTime XSetInputFocus drop ]
[ XRaiseWindow drop ]
2bi
] when* ;
M: x11-handle select-gl-context ( handle -- )

10
basis/ui/gadgets/worlds/worlds.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs continuations kernel math models
namespaces opengl opengl.capabilities opengl.textures sequences io
combinators combinators.short-circuit fry math.vectors math.rectangles
cache ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
namespaces opengl opengl.textures sequences io combinators
combinators.short-circuit fry math.vectors math.rectangles cache
ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
ui.commands ;
IN: ui.gadgets.worlds
@ -77,10 +77,6 @@ SYMBOL: flush-layout-cache-hook
flush-layout-cache-hook [ [ ] ] initialize
: check-extensions ( -- )
"2.0" { "GL_ARB_texture_non_power_of_two" } has-gl-version-or-extensions?
non-power-of-2-textures? set ;
: (draw-world) ( world -- )
dup handle>> [
check-extensions

4
basis/ui/render/render.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math.rectangles math.vectors namespaces kernel accessors
assocs combinators sequences opengl opengl.gl opengl.glu colors
assocs combinators sequences opengl opengl.gl colors
colors.constants ui.gadgets ui.pens ;
IN: ui.render
@ -22,7 +22,7 @@ SYMBOL: viewport-translation
dim>>
[ { 0 1 } v* viewport-translation set ]
[ [ { 0 0 } ] dip gl-viewport ]
[ [ 0 ] dip first2 0 gluOrtho2D ] tri
[ [ 0 ] dip first2 0 1 -1 glOrtho ] tri
]
[ clip set ] bi
do-clip ;

2
basis/ui/ui.factor
View File

@ -196,4 +196,4 @@ M: object close-window
: with-ui ( quot -- )
ui-running? [ call( -- ) ] [ '[ init-ui @ ] (with-ui) ] if ;
HOOK: beep ui-backend ( -- )
HOOK: beep ui-backend ( -- )

4
basis/urls/encoding/encoding-tests.factor
View File

@ -26,3 +26,7 @@ USING: urls.encoding tools.test arrays kernel assocs present accessors ;
[ H{ { "text" "hello world" } } ] [ "text=hello+world" query>assoc ] unit-test
[ "a=3" ] [ { { "a" 3 } } assoc>query ] unit-test
[ "a" ] [ { { "a" f } } assoc>query ] unit-test
[ H{ { "a" f } } ] [ "a" query>assoc ] unit-test

16
basis/urls/encoding/encoding.factor
View File

@ -72,6 +72,15 @@ PRIVATE>
] when*
] 2keep set-at ;
: assoc-strings ( assoc -- assoc' )
[
{
{ [ dup not ] [ ] }
{ [ dup array? ] [ [ present ] map ] }
[ present 1array ]
} cond
] assoc-map ;
PRIVATE>
: query>assoc ( query -- assoc )
@ -86,11 +95,8 @@ PRIVATE>
: assoc>query ( assoc -- str )
[
dup array? [ [ present ] map ] [ present 1array ] if
] assoc-map
[
[
assoc-strings [
[ url-encode ] dip
[ url-encode "=" glue , ] with each
[ [ url-encode "=" glue , ] with each ] [ , ] if*
] assoc-each
] { } make "&" join ;

9
basis/urls/urls-tests.factor
View File

@ -80,6 +80,15 @@ CONSTANT: urls
}
"ftp://slava:secret@ftp.kernel.org/"
}
{
T{ url
{ protocol "http" }
{ host "foo.com" }
{ path "/" }
{ query H{ { "a" f } } }
}
"http://foo.com/?a"
}
}
urls [

18
basis/windows/uniscribe/uniscribe.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs math sequences fry io.encodings.string
io.encodings.utf16n accessors arrays combinators destructors locals
cache namespaces init images.normalization fonts alien.c-types
windows windows.usp10 windows.offscreen windows.gdi32
windows.ole32 windows.types windows.fonts opengl.textures ;
io.encodings.utf16n accessors arrays combinators destructors
cache namespaces init fonts alien.c-types windows windows.usp10
windows.offscreen windows.gdi32 windows.ole32 windows.types
windows.fonts opengl.textures locals ;
IN: windows.uniscribe
TUPLE: script-string font string metrics ssa size image disposed ;
@ -59,10 +59,10 @@ TUPLE: script-string font string metrics ssa size image disposed ;
ssa>> ! ssa
0 ! iX
0 ! iY
0 ! uOptions
f ! prc
ETO_OPAQUE ! uOptions
]
[ selection-start/end ] bi
[ [ { 0 0 } ] dip size>> <RECT> ]
[ selection-start/end ] tri
! iMinSel
! iMaxSel
FALSE ! fDisabled
@ -108,8 +108,8 @@ M: script-string dispose*
SYMBOL: cached-script-strings
: cached-script-string ( string font -- script-string )
: cached-script-string ( font string -- script-string )
cached-script-strings get-global [ <script-string> ] 2cache ;
[ <cache-assoc> cached-script-strings set-global ]
"windows.uniscribe" add-init-hook
"windows.uniscribe" add-init-hook

2
basis/wrap/wrap.factor
View File

@ -30,7 +30,7 @@ SYMBOL: line-ideal
{ [ lines>> car 1list? ] [ top-fits? ] } 1|| ;
:: min-by ( seq quot -- elt )
f 1.0/0.0 seq [| key value new |
f 1/0. seq [| key value new |
new quot call :> newvalue
newvalue value < [ new newvalue ] [ key value ] if
] each drop ; inline

6
basis/x11/windows/windows.factor
View File

@ -6,10 +6,10 @@ arrays fry ;
IN: x11.windows
: create-window-mask ( -- n )
{ CWBackPixel CWBorderPixel CWColormap CWEventMask } flags ;
{ CWColormap CWEventMask } flags ;
: create-colormap ( visinfo -- colormap )
dpy get root get rot XVisualInfo-visual AllocNone
[ dpy get root get ] dip XVisualInfo-visual AllocNone
XCreateColormap ;
: event-mask ( -- n )
@ -29,8 +29,6 @@ IN: x11.windows
: window-attributes ( visinfo -- attributes )
"XSetWindowAttributes" <c-object>
0 over set-XSetWindowAttributes-background_pixel
0 over set-XSetWindowAttributes-border_pixel
[ [ create-colormap ] dip set-XSetWindowAttributes-colormap ] keep
event-mask over set-XSetWindowAttributes-event_mask ;

2
build-support/factor.sh
View File

@ -199,7 +199,7 @@ find_architecture() {
write_test_program() {
echo "#include <stdio.h>" > $C_WORD.c
echo "int main(){printf(\"%d\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c
echo "int main(){printf(\"%ld\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c
}
c_find_word_size() {

10
core/classes/tuple/tuple-docs.factor
View File

@ -92,7 +92,7 @@ ARTICLE: "tuple-constructors" "Tuple constructors"
$nl
"Constructors play a part in enforcing the invariant that slot values must always match slot declarations. The " { $link new } " word fills in the tuple with initial values, and " { $link boa } " ensures that the values on the stack match the corresponding slot declarations. See " { $link "tuple-declarations" } "."
$nl
"All tuple construction should be done through constructor words, and construction primitives should be encapsulated and never called outside of the vocabulary where the class is defined, because this encourages looser coupling. For example, a constructor word could be changed to use memoization instead of always constructing a new instance, or it could be changed to construt a different class, without breaking callers."
"All tuple construction should be done through constructor words, and construction primitives should be encapsulated and never called outside of the vocabulary where the class is defined, because this encourages looser coupling. For example, a constructor word could be changed to use memoization instead of always constructing a new instance, or it could be changed to construct a different class, without breaking callers."
$nl
"Examples of constructors:"
{ $code
@ -220,13 +220,13 @@ ARTICLE: "tuple-examples" "Tuple examples"
" <employee> \"project manager\" >>position ;" }
"An alternative strategy is to define the most general BOA constructor first:"
{ $code
": <employee> ( name position -- person )"
": <employee> ( name position -- employee )"
" 40000 employee boa ;"
}
"Now we can define more specific constructors:"
{ $code
": <manager> ( name -- person )"
" \"manager\" <person> ;" }
": <manager> ( name -- employee )"
" \"manager\" <employee> ;" }
"An example using reader words:"
{ $code
"TUPLE: check to amount number ;"
@ -256,7 +256,7 @@ ARTICLE: "tuple-examples" "Tuple examples"
": next-position ( role -- newrole )"
" positions [ index 1+ ] keep nth ;"
""
": promote ( person -- person )"
": promote ( employee -- employee )"
" [ 1.2 * ] change-salary"
" [ next-position ] change-position ;"
}

2
core/math/floats/floats-tests.factor
View File

@ -56,8 +56,6 @@ unit-test
[ t ] [ 0.0 zero? ] unit-test
[ t ] [ -0.0 zero? ] unit-test
! [ f ] [ 0.0/0.0 0.0/0.0 number= ] unit-test
[ 0 ] [ 1/0. >bignum ] unit-test
[ t ] [ 64 [ 2^ 0.5 * ] map [ < ] monotonic? ] unit-test

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

@ -122,7 +122,7 @@ M: bignum (log2) bignum-log2 ;
2drop 0.0
] [
dup zero? [
2drop 1.0/0.0
2drop 1/0.
] [
pre-scale
/f-loop over odd?

2
core/math/parser/parser-docs.factor
View File

@ -25,7 +25,7 @@ $nl
ABOUT: "number-strings"
HELP: digits>integer
{ $values { "seq" "a sequence of integers" } { "radix" "an integer between 2 and 36" } { "n" integer } }
{ $values { "seq" "a sequence of integers" } { "radix" "an integer between 2 and 36" } { "n/f" { $maybe integer } } }
{ $description "Converts a sequence of digits (with most significant digit first) into an integer." }
{ $notes "This is one of the factors of " { $link string>number } "." } ;

10
core/math/parser/parser-tests.factor
View File

@ -95,17 +95,17 @@ unit-test
[ 1 0 >base ] must-fail
[ 1 -1 >base ] must-fail
[ "0.0/0.0" ] [ 0.0 0.0 / number>string ] unit-test
[ "0/0." ] [ 0.0 0.0 / number>string ] unit-test
[ "1.0/0.0" ] [ 1.0 0.0 / number>string ] unit-test
[ "1/0." ] [ 1.0 0.0 / number>string ] unit-test
[ "-1.0/0.0" ] [ -1.0 0.0 / number>string ] unit-test
[ "-1/0." ] [ -1.0 0.0 / number>string ] unit-test
[ t ] [ "0/0." string>number fp-nan? ] unit-test
[ 1.0/0.0 ] [ "1/0." string>number ] unit-test
[ 1/0. ] [ "1/0." string>number ] unit-test
[ -1.0/0.0 ] [ "-1/0." string>number ] unit-test
[ -1/0. ] [ "-1/0." string>number ] unit-test
[ "-0.0" ] [ -0.0 number>string ] unit-test

76
core/math/parser/parser.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math.private namespaces sequences strings
arrays combinators splitting math assocs make ;
USING: kernel math.private namespaces sequences sequences.private
strings arrays combinators splitting math assocs make ;
IN: math.parser
: digit> ( ch -- n )
@ -28,13 +28,19 @@ IN: math.parser
{ CHAR: d 13 }
{ CHAR: e 14 }
{ CHAR: f 15 }
} at ;
} at 255 or ; inline
: string>digits ( str -- digits )
[ digit> ] { } map-as ;
[ digit> ] B{ } map-as ; inline
: digits>integer ( seq radix -- n )
0 swap [ swapd * + ] curry reduce ;
: (digits>integer) ( valid? accum digit radix -- valid? accum )
2dup < [ swapd * + ] [ 2drop 2drop f 0 ] if ; inline
: each-digit ( seq radix quot -- n/f )
[ t 0 ] 3dip curry each swap [ drop f ] unless ; inline
: digits>integer ( seq radix -- n/f )
[ (digits>integer) ] each-digit ; inline
DEFER: base>
@ -43,6 +49,11 @@ DEFER: base>
SYMBOL: radix
SYMBOL: negative?
: string>natural ( seq radix -- n/f )
over empty? [ 2drop f ] [
[ [ digit> ] dip (digits>integer) ] each-digit
] if ; inline
: sign ( -- str ) negative? get "-" "+" ? ;
: with-radix ( radix quot -- )
@ -54,37 +65,30 @@ SYMBOL: negative?
sign split1 [ (base>) ] dip
dup [ (base>) ] [ drop 0 swap ] if ;
: string>ratio ( str -- a/b )
"-" ?head dup negative? set swap
"/" split1 (base>) [ whole-part ] dip
3dup and and [ / + swap [ neg ] when ] [ 2drop 2drop f ] if ;
: string>ratio ( str radix -- a/b )
[
"-" ?head dup negative? set swap
"/" split1 (base>) [ whole-part ] dip
3dup and and [ / + swap [ neg ] when ] [ 2drop 2drop f ] if
] with-radix ;
: valid-digits? ( seq -- ? )
{
{ [ dup empty? ] [ drop f ] }
{ [ f over memq? ] [ drop f ] }
[ radix get [ < ] curry all? ]
} cond ;
: string>integer ( str -- n/f )
"-" ?head swap
string>digits dup valid-digits?
[ radix get digits>integer swap [ neg ] when ] [ 2drop f ] if ;
: string>integer ( str radix -- n/f )
over first-unsafe CHAR: - = [
[ rest-slice ] dip string>natural dup [ neg ] when
] [
string>natural
] if ; inline
PRIVATE>
: base> ( str radix -- n/f )
[
CHAR: / over member? [
string>ratio
] [
CHAR: . over member? [
string>float
] [
string>integer
] if
] if
] with-radix ;
over empty? [ 2drop f ] [
over [ "/." member? ] find nip {
{ CHAR: / [ string>ratio ] }
{ CHAR: . [ drop string>float ] }
[ drop string>integer ]
} case
] if ;
: string>number ( str -- n/f ) 10 base> ;
: bin> ( str -- n/f ) 2 base> ;
@ -147,9 +151,9 @@ M: ratio >base
M: float >base
drop {
{ [ dup fp-nan? ] [ drop "0.0/0.0" ] }
{ [ dup 1.0/0.0 = ] [ drop "1.0/0.0" ] }
{ [ dup -1.0/0.0 = ] [ drop "-1.0/0.0" ] }
{ [ dup fp-nan? ] [ drop "0/0." ] }
{ [ dup 1/0. = ] [ drop "1/0." ] }
{ [ dup -1/0. = ] [ drop "-1/0." ] }
{ [ dup double>bits HEX: 8000000000000000 = ] [ drop "-0.0" ] }
[ float>string fix-float ]
} cond ;

2
core/sequences/sequences-tests.factor
View File

@ -227,7 +227,7 @@ unit-test
[ -3 10 nth ] must-fail
[ 11 10 nth ] must-fail
[ -1./0. 0 delete-nth ] must-fail
[ -1/0. 0 delete-nth ] must-fail
[ "" ] [ "" [ CHAR: \s = ] trim ] unit-test
[ "" ] [ "" [ CHAR: \s = ] trim-head ] unit-test
[ "" ] [ "" [ CHAR: \s = ] trim-tail ] unit-test

6
core/syntax/syntax-docs.factor
View File

@ -66,6 +66,12 @@ ARTICLE: "syntax-floats" "Float syntax"
"7.e13"
"1.0e-5"
}
"There are three special float values:"
{ $table
{ "Positive infinity" { $snippet "1/0." } }
{ "Negative infinity" { $snippet "-1/0." } }
{ "Not-a-number" { $snippet "0/0." } }
}
"More information on floats can be found in " { $link "floats" } "." ;
ARTICLE: "syntax-complex-numbers" "Complex number syntax"

2
extra/4DNav/camera/camera.factor
View File

@ -1,4 +1,4 @@
USING: kernel namespaces math.vectors opengl 4DNav.turtle ;
USING: kernel namespaces math.vectors opengl opengl.glu 4DNav.turtle ;
IN: 4DNav.camera

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

@ -53,7 +53,7 @@ C: <sphere> sphere
: sphere-t ( b d -- t )
-+ dup 0.0 <
[ 2drop 1.0/0.0 ] [ [ [ 0.0 > ] keep ] dip ? ] if ; inline
[ 2drop 1/0. ] [ [ [ 0.0 > ] keep ] dip ? ] if ; inline
: sphere-b&v ( sphere ray -- b v )
[ sphere-v ] [ nip ] 2bi

70
extra/c/preprocessor/preprocessor.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: html.parser.state io io.encodings.utf8 io.files
USING: sequence-parser io io.encodings.utf8 io.files
io.streams.string kernel combinators accessors io.pathnames
fry sequences arrays locals namespaces io.directories
assocs math splitting make unicode.categories
@ -41,7 +41,7 @@ ifs elifs elses ;
DEFER: preprocess-file
ERROR: unknown-c-preprocessor state-parser name ;
ERROR: unknown-c-preprocessor sequence-parser name ;
ERROR: bad-include-line line ;
@ -69,8 +69,16 @@ ERROR: header-file-missing path ;
drop
] if ;
: handle-include ( preprocessor-state state-parser -- )
skip-whitespace advance dup previous {
: skip-whitespace/comments ( sequence-parser -- sequence-parser )
skip-whitespace
{
{ [ dup take-c-comment ] [ skip-whitespace/comments ] }
{ [ dup take-c++-comment ] [ skip-whitespace/comments ] }
[ ]
} cond ;
: handle-include ( preprocessor-state sequence-parser -- )
skip-whitespace/comments advance dup previous {
{ CHAR: < [ CHAR: > take-until-object read-standard-include ] }
{ CHAR: " [ CHAR: " take-until-object read-local-include ] }
[ bad-include-line ]
@ -81,58 +89,58 @@ ERROR: header-file-missing path ;
: readlns ( -- string ) [ (readlns) ] { } make concat ;
: take-define-identifier ( state-parser -- string )
skip-whitespace
: take-define-identifier ( sequence-parser -- string )
skip-whitespace/comments
[ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ;
: handle-define ( preprocessor-state state-parser -- )
: handle-define ( preprocessor-state sequence-parser -- )
[ take-define-identifier ]
[ skip-whitespace take-rest ] bi
[ skip-whitespace/comments take-rest ] bi
"\\" ?tail [ readlns append ] when
spin symbol-table>> set-at ;
: handle-undef ( preprocessor-state state-parser -- )
: handle-undef ( preprocessor-state sequence-parser -- )
take-token swap symbol-table>> delete-at ;
: handle-ifdef ( preprocessor-state state-parser -- )
: handle-ifdef ( preprocessor-state sequence-parser -- )
[ [ 1 + ] change-ifdef-nesting ] dip
take-token over symbol-table>> key?
[ drop ] [ t >>processing-disabled? drop ] if ;
: handle-ifndef ( preprocessor-state state-parser -- )
: handle-ifndef ( preprocessor-state sequence-parser -- )
[ [ 1 + ] change-ifdef-nesting ] dip
take-token over symbol-table>> key?
[ t >>processing-disabled? drop ]
[ drop ] if ;
: handle-endif ( preprocessor-state state-parser -- )
: handle-endif ( preprocessor-state sequence-parser -- )
drop [ 1 - ] change-ifdef-nesting drop ;
: handle-if ( preprocessor-state state-parser -- )
: handle-if ( preprocessor-state sequence-parser -- )
[ [ 1 + ] change-ifdef-nesting ] dip
skip-whitespace take-rest swap ifs>> push ;
skip-whitespace/comments take-rest swap ifs>> push ;
: handle-elif ( preprocessor-state state-parser -- )
skip-whitespace take-rest swap elifs>> push ;
: handle-elif ( preprocessor-state sequence-parser -- )
skip-whitespace/comments take-rest swap elifs>> push ;
: handle-else ( preprocessor-state state-parser -- )
skip-whitespace take-rest swap elses>> push ;
: handle-else ( preprocessor-state sequence-parser -- )
skip-whitespace/comments take-rest swap elses>> push ;
: handle-pragma ( preprocessor-state state-parser -- )
skip-whitespace take-rest swap pragmas>> push ;
: handle-pragma ( preprocessor-state sequence-parser -- )
skip-whitespace/comments take-rest swap pragmas>> push ;
: handle-include-next ( preprocessor-state state-parser -- )
skip-whitespace take-rest swap include-nexts>> push ;
: handle-include-next ( preprocessor-state sequence-parser -- )
skip-whitespace/comments take-rest swap include-nexts>> push ;
: handle-error ( preprocessor-state state-parser -- )
skip-whitespace take-rest swap errors>> push ;
: handle-error ( preprocessor-state sequence-parser -- )
skip-whitespace/comments take-rest swap errors>> push ;
! nip take-rest throw ;
: handle-warning ( preprocessor-state state-parser -- )
skip-whitespace
: handle-warning ( preprocessor-state sequence-parser -- )
skip-whitespace/comments
take-rest swap warnings>> push ;
: parse-directive ( preprocessor-state state-parser string -- )
: parse-directive ( preprocessor-state sequence-parser string -- )
{
{ "warning" [ handle-warning ] }
{ "error" [ handle-error ] }
@ -150,7 +158,7 @@ ERROR: header-file-missing path ;
[ unknown-c-preprocessor ]
} case ;
: parse-directive-line ( preprocessor-state state-parser -- )
: parse-directive-line ( preprocessor-state sequence-parser -- )
advance dup take-token
pick processing-disabled?>> [
"endif" = [
@ -162,14 +170,14 @@ ERROR: header-file-missing path ;
parse-directive
] if ;
: preprocess-line ( preprocessor-state state-parser -- )
skip-whitespace dup current CHAR: # =
: preprocess-line ( preprocessor-state sequence-parser -- )
skip-whitespace/comments dup current CHAR: # =
[ parse-directive-line ]
[ swap processing-disabled?>> [ drop ] [ write-full nl ] if ] if ;
: preprocess-lines ( preprocessor-state -- )
readln
[ <state-parser> [ preprocess-line ] [ drop preprocess-lines ] 2bi ]
[ <sequence-parser> [ preprocess-line ] [ drop preprocess-lines ] 2bi ]
[ drop ] if* ;
ERROR: include-nested-too-deeply ;

46
extra/html/parser/parser.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays hashtables html.parser.state
USING: accessors arrays hashtables sequence-parser
html.parser.utils kernel namespaces sequences
unicode.case unicode.categories combinators.short-circuit
quoting fry ;
@ -37,89 +37,89 @@ SYMBOL: tagstack
swap >>name
swap >>text ; inline
: (read-quote) ( state-parser ch -- string )
: (read-quote) ( sequence-parser ch -- string )
'[ [ current _ = ] take-until ] [ advance drop ] bi ;
: read-single-quote ( state-parser -- string )
: read-single-quote ( sequence-parser -- string )
CHAR: ' (read-quote) ;
: read-double-quote ( state-parser -- string )
: read-double-quote ( sequence-parser -- string )
CHAR: " (read-quote) ;
: read-quote ( state-parser -- string )
: read-quote ( sequence-parser -- string )
dup get+increment CHAR: ' =
[ read-single-quote ] [ read-double-quote ] if ;
: read-key ( state-parser -- string )
: read-key ( sequence-parser -- string )
skip-whitespace
[ current { [ CHAR: = = ] [ blank? ] } 1|| ] take-until ;
: read-token ( state-parser -- string )
: read-token ( sequence-parser -- string )
[ current blank? ] take-until ;
: read-value ( state-parser -- string )
: read-value ( sequence-parser -- string )
skip-whitespace
dup current quote? [ read-quote ] [ read-token ] if
[ blank? ] trim ;
: read-comment ( state-parser -- )
: read-comment ( sequence-parser -- )
"-->" take-until-sequence comment new-tag push-tag ;
: read-dtd ( state-parser -- )
: read-dtd ( sequence-parser -- )
">" take-until-sequence dtd new-tag push-tag ;
: read-bang ( state-parser -- )
: read-bang ( sequence-parser -- )
advance dup { [ current CHAR: - = ] [ peek-next CHAR: - = ] } 1&&
[ advance advance read-comment ] [ read-dtd ] if ;
: read-tag ( state-parser -- string )
: read-tag ( sequence-parser -- string )
[ [ current "><" member? ] take-until ]
[ dup current CHAR: < = [ advance ] unless drop ] bi ;
: read-until-< ( state-parser -- string )
: read-until-< ( sequence-parser -- string )
[ current CHAR: < = ] take-until ;
: parse-text ( state-parser -- )
: parse-text ( sequence-parser -- )
read-until-< [ text new-tag push-tag ] unless-empty ;
: parse-key/value ( state-parser -- key value )
: parse-key/value ( sequence-parser -- key value )
[ read-key >lower ]
[ skip-whitespace "=" take-sequence ]
[ swap [ read-value ] [ drop dup ] if ] tri ;
: (parse-attributes) ( state-parser -- )
: (parse-attributes) ( sequence-parser -- )
skip-whitespace
dup state-parse-end? [
dup sequence-parse-end? [
drop
] [
[ parse-key/value swap set ] [ (parse-attributes) ] bi
] if ;
: parse-attributes ( state-parser -- hashtable )
: parse-attributes ( sequence-parser -- hashtable )
[ (parse-attributes) ] H{ } make-assoc ;
: (parse-tag) ( string -- string' hashtable )
[
[ read-token >lower ] [ parse-attributes ] bi
] state-parse ;
] parse-sequence ;
: read-< ( state-parser -- string/f )
: read-< ( sequence-parser -- string/f )
advance dup current [
CHAR: ! = [ read-bang f ] [ read-tag ] if
] [
drop f
] if* ;
: parse-tag ( state-parser -- )
: parse-tag ( sequence-parser -- )
read-< [ (parse-tag) make-tag push-tag ] unless-empty ;
: (parse-html) ( state-parser -- )
: (parse-html) ( sequence-parser -- )
dup peek-next [
[ parse-text ] [ parse-tag ] [ (parse-html) ] tri
] [ drop ] if ;
: tag-parse ( quot -- vector )
V{ } clone tagstack [ state-parse ] with-variable ; inline
V{ } clone tagstack [ parse-sequence ] with-variable ; inline
PRIVATE>

104
extra/html/parser/state/state-tests.factor
View File

@ -1,104 +0,0 @@
USING: tools.test html.parser.state ascii kernel accessors ;
IN: html.parser.state.tests
[ "hello" ]
[ "hello" [ take-rest ] state-parse ] unit-test
[ "hi" " how are you?" ]
[
"hi how are you?"
[ [ [ current blank? ] take-until ] [ take-rest ] bi ] state-parse
] unit-test
[ "foo" ";bar" ]
[
"foo;bar" [
[ CHAR: ; take-until-object ] [ take-rest ] bi
] state-parse
] unit-test
[ "foo " " bar" ]
[
"foo and bar" [
[ "and" take-until-sequence ] [ take-rest ] bi
] state-parse
] unit-test
[ 6 ]
[
" foo " [ skip-whitespace n>> ] state-parse
] unit-test
[ { 1 2 } ]
[ { 1 2 3 } <state-parser> [ current 3 = ] take-until ] unit-test
[ { 1 2 } ]
[ { 1 2 3 4 } <state-parser> { 3 4 } take-until-sequence ] unit-test
[ "ab" ]
[ "abcd" <state-parser> "ab" take-sequence ] unit-test
[ f ]
[ "abcd" <state-parser> "lol" take-sequence ] unit-test
[ "ab" ]
[
"abcd" <state-parser>
[ "lol" take-sequence drop ] [ "ab" take-sequence ] bi
] unit-test
[ "" ]
[ "abcd" <state-parser> "" take-sequence ] unit-test
[ "cd" ]
[ "abcd" <state-parser> [ "ab" take-sequence drop ] [ "cd" take-sequence ] bi ] unit-test
[ f ]
[
"\"abc\" asdf" <state-parser>
[ CHAR: \ CHAR: " take-quoted-string drop ] [ "asdf" take-sequence ] bi
] unit-test
[ "abc\\\"def" ]
[
"\"abc\\\"def\" asdf" <state-parser>
CHAR: \ CHAR: " take-quoted-string
] unit-test
[ "asdf" ]
[
"\"abc\" asdf" <state-parser>
[ CHAR: \ CHAR: " take-quoted-string drop ]
[ skip-whitespace "asdf" take-sequence ] bi
] unit-test
[ f ]
[
"\"abc asdf" <state-parser>
CHAR: \ CHAR: " take-quoted-string
] unit-test
[ "\"abc" ]
[
"\"abc asdf" <state-parser>
[ CHAR: \ CHAR: " take-quoted-string drop ]
[ "\"abc" take-sequence ] bi
] unit-test
[ "c" ]
[ "c" <state-parser> take-token ] unit-test
[ f ]
[ "" <state-parser> take-token ] unit-test
[ "abcd e \\\"f g" ]
[ "\"abcd e \\\"f g\"" <state-parser> CHAR: \ CHAR: " take-token* ] unit-test
[ "" ]
[ "" <state-parser> take-rest ] unit-test
[ "" ]
[ "abc" <state-parser> dup "abc" take-sequence drop take-rest ] unit-test
[ f ]
[ "abc" <state-parser> "abcdefg" take-sequence ] unit-test

127
extra/html/parser/state/state.factor
View File

@ -1,127 +0,0 @@
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces math kernel sequences accessors fry circular
unicode.case unicode.categories locals combinators.short-circuit
make combinators io splitting ;
IN: html.parser.state
TUPLE: state-parser sequence n ;
: <state-parser> ( sequence -- state-parser )
state-parser new
swap >>sequence
0 >>n ;
: offset ( state-parser offset -- char/f )
swap
[ n>> + ] [ sequence>> ?nth ] bi ; inline
: current ( state-parser -- char/f ) 0 offset ; inline
: previous ( state-parser -- char/f ) -1 offset ; inline
: peek-next ( state-parser -- char/f ) 1 offset ; inline
: advance ( state-parser -- state-parser )
[ 1 + ] change-n ; inline
: advance* ( state-parser -- )
advance drop ; inline
: get+increment ( state-parser -- char/f )
[ current ] [ advance drop ] bi ; inline
:: skip-until ( state-parser quot: ( obj -- ? ) -- )
state-parser current [
state-parser quot call [ state-parser advance quot skip-until ] unless
] when ; inline recursive
: state-parse-end? ( state-parser -- ? ) current not ;
: take-until ( state-parser quot: ( obj -- ? ) -- sequence/f )
over state-parse-end? [
2drop f
] [
[ drop n>> ]
[ skip-until ]
[ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq
] if ; inline
: take-while ( state-parser quot: ( obj -- ? ) -- sequence/f )
[ not ] compose take-until ; inline
: <safe-slice> ( from to seq -- slice/f )
3dup {
[ 2drop 0 < ]
[ [ drop ] 2dip length > ]
[ drop > ]
} 3|| [ 3drop f ] [ slice boa ] if ; inline
:: take-sequence ( state-parser sequence -- obj/f )
state-parser [ n>> dup sequence length + ] [ sequence>> ] bi
<safe-slice> sequence sequence= [
sequence
state-parser [ sequence length + ] change-n drop
] [
f
] if ;
:: take-until-sequence ( state-parser sequence -- sequence' )
sequence length <growing-circular> :> growing
state-parser
[
current growing push-growing-circular
sequence growing sequence=
] take-until :> found
found dup length
growing length 1- - head
state-parser advance drop ;
: skip-whitespace ( state-parser -- state-parser )
[ [ current blank? not ] take-until drop ] keep ;
: take-rest-slice ( state-parser -- sequence/f )
[ sequence>> ] [ n>> ] bi
2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline
: take-rest ( state-parser -- sequence )
[ take-rest-slice ] [ sequence>> like ] bi ;
: take-until-object ( state-parser obj -- sequence )
'[ current _ = ] take-until ;
: state-parse ( sequence quot -- )
[ <state-parser> ] dip call ; inline
:: take-quoted-string ( state-parser escape-char quote-char -- string )
state-parser n>> :> start-n
state-parser advance
[
{
[ { [ previous escape-char = ] [ current quote-char = ] } 1&& ]
[ current quote-char = not ]
} 1||
] take-while :> string
state-parser current quote-char = [
state-parser advance* string
] [
start-n state-parser (>>n) f
] if ;
: (take-token) ( state-parser -- string )
skip-whitespace [ current { [ blank? ] [ f = ] } 1|| ] take-until ;
:: take-token* ( state-parser escape-char quote-char -- string/f )
state-parser skip-whitespace
dup current {
{ quote-char [ escape-char quote-char take-quoted-string ] }
{ f [ drop f ] }
[ drop (take-token) ]
} case ;
: take-token ( state-parser -- string/f )
CHAR: \ CHAR: " take-token* ;
: write-full ( state-parser -- ) sequence>> write ;
: write-rest ( state-parser -- ) take-rest write ;

4
extra/html/parser/utils/utils.factor
View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: assocs circular combinators continuations hashtables
hashtables.private io kernel math namespaces prettyprint
quotations sequences splitting html.parser.state strings
combinators.short-circuit quoting ;
quotations sequences splitting strings quoting
combinators.short-circuit ;
IN: html.parser.utils
: trim1 ( seq ch -- newseq )

28
extra/id3/id3-docs.factor
View File

@ -7,7 +7,7 @@ IN: id3
HELP: mp3>id3
{ $values
{ "path" "a path string" }
{ "id3v2-info/f" "a tuple storing ID3v2 metadata or f" } }
{ "id3/f" "a tuple storing ID3v2 metadata or f" } }
{ $description "Return a tuple containing the ID3 information parsed out of the MP3 file, or " { $link f } " if no metadata is present. Words to access the ID3v1 information are here:"
{ $list
{ $link title }
@ -22,49 +22,49 @@ HELP: mp3>id3
HELP: album
{ $values
{ "id3" id3v2-info }
{ "album/f" "string or f" }
{ "id3" id3 }
{ "string/f" "string or f" }
}
{ $description "Returns the album, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
HELP: artist
{ $values
{ "id3" id3v2-info }
{ "artist/f" "string or f" }
{ "id3" id3 }
{ "string/f" "string or f" }
}
{ $description "Returns the artist, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
HELP: comment
{ $values
{ "id3" id3v2-info }
{ "comment/f" "string or f" }
{ "id3" id3 }
{ "string/f" "string or f" }
}
{ $description "Returns the comment, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
HELP: genre
{ $values
{ "id3" id3v2-info }
{ "genre/f" "string or f" }
{ "id3" id3 }
{ "string/f" "string or f" }
}
{ $description "Returns the genre, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
HELP: title
{ $values
{ "id3" id3v2-info }
{ "title/f" "string or f" }
{ "id3" id3 }
{ "string/f" "string or f" }
}
{ $description "Returns the title, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
HELP: year
{ $values
{ "id3" id3v2-info }
{ "year/f" "string or f" }
{ "id3" id3 }
{ "string/f" "string or f" }
}
{ $description "Returns the year, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
HELP: find-id3-frame
{ $values
{ "id3" id3v2-info } { "name" string }
{ "id3" id3 } { "name" string }
{ "obj/f" "object or f" }
}
{ $description "Returns the " { $slot "data" } " slot of the ID3 frame with the given name, or " { $link f } "." } ;

6
extra/id3/id3-tests.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2009 Tim Wawrzynczak
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test id3 combinators ;
USING: tools.test id3 combinators grouping id3.private
sequences math ;
IN: id3.tests
: id3-params ( id3 -- title artist album year comment genre )
@ -40,3 +41,6 @@ IN: id3.tests
"Big Band"
] [ "vocab:id3/tests/blah3.mp3" mp3>id3 id3-params ] unit-test
[ t ]
[ 10000 [ synchsafe>seq seq>synchsafe ] map [ < ] monotonic? ] unit-test

206
extra/id3/id3.factor
View File

@ -6,7 +6,7 @@ combinators math.ranges unicode.categories byte-arrays
io.encodings.string io.encodings.utf16 assocs math.parser
combinators.short-circuit fry namespaces combinators.smart
splitting io.encodings.ascii arrays io.files.info unicode.case
io.directories.search ;
io.directories.search literals math.functions ;
IN: id3
<PRIVATE
@ -37,103 +37,132 @@ CONSTANT: genres
"Primus" "Porn Groove" "Satire" "Slow Jam" "Club" "Tango"
"Samba" "Folklore" "Ballad" "Power Ballad" "Rhythmic Soul"
"Freestyle" "Duet" "Punk Rock" "Drum Solo" "A capella"
"Euro-House" "Dance Hall"
"Euro-House" "Dance Hall" "Goa" "Drum & Bass" "Club-House"
"Hardcore" "Terror" "Indie" "BritPop" "Negerpunk"
"Polsk Punk" "Beat" "Christian Gangsta Rap" "Heavy Metal"
"Black Metal" "Crossover" "Contemporary Christian"
"Christian Rock"
}
TUPLE: header version flags size ;
TUPLE: frame frame-id flags size data ;
TUPLE: frame tag flags size data ;
TUPLE: id3v2-info header frames ;
TUPLE: id3 header frames
title artist album year comment genre
speed genre-name start-time end-time ;
TUPLE: id3v1-info title artist album year comment genre ;
: <id3v1-info> ( -- object ) id3v1-info new ; inline
: <id3v2-info> ( header frames -- object )
[ [ frame-id>> ] keep ] H{ } map>assoc id3v2-info boa ;
: <id3> ( -- id3 )
id3 new
H{ } clone >>frames ; inline
: <header> ( -- object ) header new ; inline
: <frame> ( -- object ) frame new ; inline
: id3v2? ( mmap -- ? ) "ID3" head? ; inline
: id3v2? ( seq -- ? ) "ID3" head? ; inline
: id3v1? ( mmap -- ? )
{ [ length 128 >= ] [ 128 tail-slice* "TAG" head? ] } 1&& ; inline
CONSTANT: id3v1-length 128
CONSTANT: id3v1-offset 128
CONSTANT: id3v1+-length 227
CONSTANT: id3v1+-offset $[ 128 227 + ]
: id3v1-frame ( string key -- frame )
<frame>
swap >>frame-id
swap >>data ; inline
: id3v1? ( seq -- ? )
{
[ length id3v1-offset >= ]
[ id3v1-length tail-slice* "TAG" head? ]
} 1&& ;
: id3v1>id3v2 ( id3v1 -- id3v2 )
: id3v1+? ( seq -- ? )
{
[ length id3v1+-offset >= ]
[ id3v1+-length tail-slice* "TAG+" head? ]
} 1&& ;
: pair>frame ( string key -- frame/f )
over [
<frame>
swap >>tag
swap >>data
] [
2drop f
] if ;
: id3v1>frames ( id3v1 -- seq )
[
{
[ title>> "TIT2" id3v1-frame ]
[ artist>> "TPE1" id3v1-frame ]
[ album>> "TALB" id3v1-frame ]
[ year>> "TYER" id3v1-frame ]
[ comment>> "COMM" id3v1-frame ]
[ genre>> "TCON" id3v1-frame ]
[ title>> "TIT2" pair>frame ]
[ artist>> "TPE1" pair>frame ]
[ album>> "TALB" pair>frame ]
[ year>> "TYER" pair>frame ]
[ comment>> "COMM" pair>frame ]
[ genre>> "TCON" pair>frame ]
} cleave
] output>array f swap <id3v2-info> ; inline
] output>array sift ;
: >28bitword ( seq -- int )
0 [ [ 7 shift ] dip bitor ] reduce ; inline
: seq>synchsafe ( seq -- n )
0 [ [ 7 shift ] dip bitor ] reduce ;
: synchsafe>seq ( n -- seq )
dup 1+ log2 1+ 7 / ceiling
[ [ -7 shift ] keep HEX: 7f bitand ] replicate nip reverse ;
: filter-text-data ( data -- filtered )
[ printable? ] filter ; inline
[ printable? ] filter ;
: valid-frame-id? ( id -- ? )
[ { [ digit? ] [ LETTER? ] } 1|| ] all? ; inline
: valid-tag? ( id -- ? )
[ { [ digit? ] [ LETTER? ] } 1|| ] all? ;
: read-frame-data ( frame mmap -- frame data )
[ 10 over size>> 10 + ] dip <slice> filter-text-data ; inline
: read-frame-data ( frame seq -- frame data )
[ 10 over size>> 10 + ] dip <slice> filter-text-data ;
: decode-text ( string -- string' )
dup 2 short head
{ { HEX: ff HEX: fe } { HEX: fe HEX: ff } } member?
utf16 ascii ? decode ; inline
utf16 ascii ? decode ;
: (read-frame) ( mmap -- frame )
: (read-frame) ( seq -- frame )
[ <frame> ] dip
{
[ 4 head-slice decode-text >>frame-id ]
[ [ 4 8 ] dip subseq >28bitword >>size ]
[ 4 head-slice decode-text >>tag ]
[ [ 4 8 ] dip subseq seq>synchsafe >>size ]
[ [ 8 10 ] dip subseq >byte-array >>flags ]
[ read-frame-data decode-text >>data ]
} cleave ; inline
} cleave ;
: read-frame ( mmap -- frame/f )
dup 4 head-slice valid-frame-id?
[ (read-frame) ] [ drop f ] if ; inline
: read-frame ( seq -- frame/f )
dup 4 head-slice valid-tag?
[ (read-frame) ] [ drop f ] if ;
: remove-frame ( mmap frame -- mmap )
size>> 10 + tail-slice ; inline
: remove-frame ( seq frame -- seq )
size>> 10 + tail-slice ;
: read-frames ( mmap -- frames )
[ dup read-frame dup ]
[ [ remove-frame ] keep ]
produce 2nip ; inline
: frames>assoc ( seq -- assoc )
[ [ tag>> ] keep ] H{ } map>assoc ;
: read-frames ( seq -- assoc )
[ dup read-frame dup ] [ [ remove-frame ] keep ] produce 2nip ;
: read-v2-header ( seq -- id3header )
: read-v2-header ( seq -- header )
[ <header> ] dip
{
[ [ 3 5 ] dip <slice> >array >>version ]
[ [ 5 ] dip nth >>flags ]
[ [ 6 10 ] dip <slice> >28bitword >>size ]
} cleave ; inline
[ [ 6 10 ] dip <slice> seq>synchsafe >>size ]
} cleave ;
: read-v2-tag-data ( seq -- id3v2-info )
: merge-frames ( id3 assoc -- id3 )
[ dup frames>> ] dip update ;
: merge-id3v1 ( id3 -- id3 )
dup id3v1>frames frames>assoc merge-frames ;
: read-v2-tags ( id3 seq -- id3 )
10 cut-slice
[ read-v2-header ]
[ read-frames ] bi* <id3v2-info> ; inline
[ read-v2-header >>header ]
[ read-frames frames>assoc merge-frames ] bi* ;
: skip-to-v1-data ( seq -- seq ) 125 tail-slice* ; inline
: (read-v1-tag-data) ( seq -- mp3-file )
[ <id3v1-info> ] dip
: extract-v1-tags ( id3 seq -- id3 )
{
[ 30 head-slice decode-text filter-text-data >>title ]
[ [ 30 60 ] dip subseq decode-text filter-text-data >>artist ]
@ -141,10 +170,32 @@ TUPLE: id3v1-info title artist album year comment genre ;
[ [ 90 94 ] dip subseq decode-text filter-text-data >>year ]
[ [ 94 124 ] dip subseq decode-text filter-text-data >>comment ]
[ [ 124 ] dip nth number>string >>genre ]
} cleave ; inline
} cleave ;
: read-v1-tag-data ( seq -- mp3-file )
skip-to-v1-data (read-v1-tag-data) ; inline
: read-v1-tags ( id3 seq -- id3 )
id3v1-offset tail-slice* 3 tail-slice
extract-v1-tags ;
: extract-v1+-tags ( id3 seq -- id3 )
{
[ 60 head-slice decode-text filter-text-data [ append ] change-title ]
[
[ 60 120 ] dip subseq decode-text filter-text-data
[ append ] change-artist
]
[
[ 120 180 ] dip subseq decode-text filter-text-data
[ append ] change-album
]
[ [ 180 ] dip nth >>speed ]
[ [ 181 211 ] dip subseq decode-text >>genre-name ]
[ [ 211 217 ] dip subseq decode-text >>start-time ]
[ [ 217 223 ] dip subseq decode-text >>end-time ]
} cleave ;
: read-v1+-tags ( id3 seq -- id3 )
id3v1+-offset tail-slice* 4 tail-slice
extract-v1+-tags ;
: parse-genre ( string -- n/f )
dup "(" ?head-slice drop ")" ?tail-slice drop
@ -152,43 +203,44 @@ TUPLE: id3v1-info title artist album year comment genre ;
genres ?nth swap or
] [
drop
] if ; inline
] if ;
: (mp3>id3) ( path -- id3v2-info/f )
: (mp3>id3) ( path -- id3v2/f )
[
[ <id3> ] dip
{
{ [ dup id3v2? ] [ read-v2-tag-data ] }
{ [ dup id3v1? ] [ read-v1-tag-data id3v1>id3v2 ] }
[ drop f ]
} cond
[ dup id3v1? [ read-v1-tags merge-id3v1 ] [ drop ] if ]
[ dup id3v1+? [ read-v1+-tags merge-id3v1 ] [ drop ] if ]
[ dup id3v2? [ read-v2-tags ] [ drop ] if ]
} cleave
] with-mapped-uchar-file ;
PRIVATE>
: mp3>id3 ( path -- id3v2-info/f )
dup file-info size>> 0 <= [ drop f ] [ (mp3>id3) ] if ; inline
: mp3>id3 ( path -- id3/f )
dup file-info size>> 0 <= [ drop f ] [ (mp3>id3) ] if ;
: find-id3-frame ( id3 name -- obj/f )
swap frames>> at* [ data>> ] when ; inline
swap frames>> at* [ data>> ] when ;
: title ( id3 -- title/f ) "TIT2" find-id3-frame ; inline
: title ( id3 -- string/f ) "TIT2" find-id3-frame ;
: artist ( id3 -- artist/f ) "TPE1" find-id3-frame ; inline
: artist ( id3 -- string/f ) "TPE1" find-id3-frame ;
: album ( id3 -- album/f ) "TALB" find-id3-frame ; inline
: album ( id3 -- string/f ) "TALB" find-id3-frame ;
: year ( id3 -- year/f ) "TYER" find-id3-frame ; inline
: year ( id3 -- string/f ) "TYER" find-id3-frame ;
: comment ( id3 -- comment/f ) "COMM" find-id3-frame ; inline
: comment ( id3 -- string/f ) "COMM" find-id3-frame ;
: genre ( id3 -- genre/f )
"TCON" find-id3-frame parse-genre ; inline
: genre ( id3 -- string/f )
"TCON" find-id3-frame parse-genre ;
: find-mp3s ( path -- seq )
[ >lower ".mp3" tail? ] find-all-files ; inline
[ >lower ".mp3" tail? ] find-all-files ;
: mp3-paths>id3s ( seq -- seq' )
[ dup mp3>id3 ] { } map>assoc ; inline
[ dup mp3>id3 ] { } map>assoc ;
: parse-mp3-directory ( path -- seq )
find-mp3s mp3-paths>id3s ;

0
basis/images/normalization/authors.txt → extra/images/normalization/authors.txt
View File

0
basis/images/normalization/normalization.factor → extra/images/normalization/normalization.factor
View File

1
extra/irc/client/base/authors.txt Normal file
View File

@ -0,0 +1 @@
Bruno Deferrari

37
extra/irc/client/base/base.factor Normal file
View File

@ -0,0 +1,37 @@
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs concurrency.mailboxes io kernel namespaces
strings words.symbol irc.client.chats irc.messages ;
EXCLUDE: sequences => join ;
IN: irc.client.base
SYMBOL: current-irc-client
: irc> ( -- irc-client ) current-irc-client get ;
: stream> ( -- stream ) irc> stream>> ;
: irc-print ( s -- ) stream> [ stream-print ] [ stream-flush ] bi ;
: irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ;
: chats> ( -- seq ) irc> chats>> values ;
: me? ( string -- ? ) irc> nick>> = ;
: with-irc ( irc-client quot: ( -- ) -- )
\ current-irc-client swap with-variable ; inline
UNION: to-target privmsg notice ;
UNION: to-channel join part topic kick rpl-channel-modes
rpl-notopic rpl-topic rpl-names rpl-names-end ;
UNION: to-one-chat to-target to-channel mode ;
UNION: to-many-chats nick quit ;
UNION: to-all-chats irc-end irc-disconnected irc-connected ;
PREDICATE: to-me < to-target target>> me? ;
GENERIC: chat-name ( irc-message -- name )
M: mode chat-name name>> ;
M: to-target chat-name target>> ;
M: to-me chat-name sender>> ;
M: to-channel chat-name channel>> ;
GENERIC: chat> ( obj -- chat/f )
M: string chat> irc> chats>> at ;
M: symbol chat> irc> chats>> at ;
M: to-one-chat chat> chat-name +server-chat+ or chat> ;

1
extra/irc/client/chats/authors.txt Normal file
View File

@ -0,0 +1 @@
Bruno Deferrari

22
extra/irc/client/chats/chats-docs.factor Normal file
View File

@ -0,0 +1,22 @@
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax quotations kernel ;
IN: irc.client.chats
HELP: irc-client "IRC Client object" ;
HELP: irc-server-chat "Chat for server messages unmanaged by other chats" ;
HELP: irc-channel-chat "Chat for irc channels" ;
HELP: irc-nick-chat "Chat for irc users" ;
HELP: irc-profile "IRC Client profile object" ;
HELP: irc-chat-end "Message sent to a chat when it has been detached from the client, the chat should stop after it receives this message." ;
HELP: irc-end "Message sent when the client isn't running anymore, the chat should stop after it receives this message." ;
HELP: irc-disconnected "Message sent to notify chats that connection was lost." ;
HELP: irc-connected "Message sent to notify chats that a connection with the irc server was established." ;

50
extra/irc/client/chats/chats.factor Normal file
View File

@ -0,0 +1,50 @@
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: accessors concurrency.mailboxes kernel calendar io.sockets io.encodings.8-bit
destructors arrays sequences ;
IN: irc.client.chats
CONSTANT: irc-port 6667 ! Default irc port
TUPLE: irc-chat in-messages client ;
TUPLE: irc-server-chat < irc-chat ;
TUPLE: irc-channel-chat < irc-chat name password participants clear-participants ;
TUPLE: irc-nick-chat < irc-chat name ;
SYMBOL: +server-chat+
: <irc-server-chat> ( -- irc-server-chat )
irc-server-chat new
<mailbox> >>in-messages ;
: <irc-channel-chat> ( name -- irc-channel-chat )
irc-channel-chat new
swap >>name
<mailbox> >>in-messages
f >>password
H{ } clone >>participants
t >>clear-participants ;
: <irc-nick-chat> ( name -- irc-nick-chat )
irc-nick-chat new
swap >>name
<mailbox> >>in-messages ;
TUPLE: irc-profile server port nickname password ;
C: <irc-profile> irc-profile
TUPLE: irc-client profile stream in-messages out-messages
chats is-running nick connect reconnect-time is-ready
exceptions ;
: <irc-client> ( profile -- irc-client )
dup nickname>> irc-client new
swap >>nick
swap >>profile
<mailbox> >>in-messages
<mailbox> >>out-messages
H{ } clone >>chats
15 seconds >>reconnect-time
V{ } clone >>exceptions
[ <inet> latin1 <client> ] >>connect ;
SINGLETONS: irc-chat-end irc-end irc-disconnected irc-connected ;

1
extra/irc/client/chats/summary.txt Normal file
View File

@ -0,0 +1 @@
IRC Client and Chat object definitions

28
extra/irc/client/client-docs.factor
View File

@ -1,16 +1,9 @@
USING: help.markup help.syntax quotations kernel irc.messages ;
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax quotations kernel
irc.messages irc.messages.base irc.messages.parser irc.client.chats ;
IN: irc.client
HELP: irc-client "IRC Client object" ;
HELP: irc-server-chat "Chat for server messages unmanaged by other chats" ;
HELP: irc-channel-chat "Chat for irc channels" ;
HELP: irc-nick-chat "Chat for irc users" ;
HELP: irc-profile "IRC Client profile object" ;
HELP: connect-irc "Connecting to an irc server"
{ $values { "irc-client" "an irc client object" } }
{ $description "Connects and logins " { $link irc-client } " using the settings specified on its " { $link irc-profile } "." } ;
@ -56,30 +49,31 @@ ARTICLE: "irc.client" "IRC Client"
"Some of the RFC defined irc messages as objects:"
{ $table
{ { $link irc-message } "base of all irc messages" }
{ { $link logged-in } "logged in to server" }
{ { $link rpl-welcome } "logged in to server" }
{ { $link ping } "ping message" }
{ { $link join } "channel join" }
{ { $link part } "channel part" }
{ { $link quit } "quit from irc" }
{ { $link privmsg } "private message (to client or channel)" }
{ { $link kick } "kick from channel" }
{ { $link roomlist } "list of participants in channel" }
{ { $link nick-in-use } "chosen nick is in use by another client" }
{ { $link rpl-names } "list of participants in channel" }
{ { $link rpl-nickname-in-use } "chosen nick is in use by another client" }
{ { $link notice } "notice message" }
{ { $link mode } "mode change" }
{ { $link unhandled } "uninmplemented/unhandled message" }
}
{ $heading "Special messages" }
"Some special messages that are created by the library and not by the irc server."
{ $table
{ { $link irc-chat-end } "sent to a chat when it has been detached from the client, the chat should stop after it receives this message. " }
{ { $link irc-end } " sent when the client isn't running anymore, chats should stop after it receives this message." }
{ { $link irc-end } " sent when the client isn't running anymore, the chat should stop after it receives this message." }
{ { $link irc-disconnected } " sent to notify chats that connection was lost." }
{ { $link irc-connected } " sent to notify chats that a connection with the irc server was established." } }
{ $heading "Example:" }
{ $code
"USING: irc.client ;"
"USING: irc.client irc.client.chats ;"
"SYMBOL: bot"
"SYMBOL: mychannel"
"! Create the profile and client objects"
@ -91,7 +85,7 @@ ARTICLE: "irc.client" "IRC Client"
"! Register and start chat (this joins the channel)"
"mychannel get bot get attach-chat"
"! Send a message to the channel"
"\"what's up?\" mychannel get speak"
"\"Hello World!\" mychannel get speak"
"! Read a message from the channel"
"mychannel get hear"
}

384
extra/irc/client/client.factor
View File

@ -1,383 +1,15 @@
! Copyright (C) 2008 Bruno Deferrari, Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: concurrency.mailboxes kernel io.sockets io.encodings.8-bit calendar
accessors destructors namespaces io assocs arrays fry
continuations threads strings classes combinators splitting hashtables
ascii irc.messages ;
RENAME: join sequences => sjoin
EXCLUDE: sequences => join ;
USING: accessors concurrency.mailboxes destructors
irc.client.base irc.client.chats irc.client.internals kernel
namespaces sequences ;
IN: irc.client
! ======================================
! Setup and running objects
! ======================================
CONSTANT: irc-port 6667 ! Default irc port
TUPLE: irc-profile server port nickname password ;
C: <irc-profile> irc-profile
TUPLE: irc-client profile stream in-messages out-messages
chats is-running nick connect reconnect-time is-ready ;
: <irc-client> ( profile -- irc-client )
irc-client new
swap >>profile
<mailbox> >>in-messages
<mailbox> >>out-messages
H{ } clone >>chats
dup profile>> nickname>> >>nick
[ <inet> latin1 <client> ] >>connect
15 seconds >>reconnect-time ;
TUPLE: irc-chat in-messages client ;
TUPLE: irc-server-chat < irc-chat ;
TUPLE: irc-channel-chat < irc-chat name password timeout participants clean-participants ;
TUPLE: irc-nick-chat < irc-chat name ;
SYMBOL: +server-chat+
! participant modes
SYMBOL: +operator+
SYMBOL: +voice+
SYMBOL: +normal+
: participant-mode ( n -- mode )
H{ { 64 +operator+ } { 43 +voice+ } { 0 +normal+ } } at ;
! participant changed actions
SYMBOL: +join+
SYMBOL: +part+
SYMBOL: +mode+
SYMBOL: +nick+
! chat objects
: <irc-server-chat> ( -- irc-server-chat )
<mailbox> f irc-server-chat boa ;
: <irc-channel-chat> ( name -- irc-channel-chat )
[ <mailbox> f ] dip f 60 seconds H{ } clone t
irc-channel-chat boa ;
: <irc-nick-chat> ( name -- irc-nick-chat )
[ <mailbox> f ] dip irc-nick-chat boa ;
! ======================================
! Message objects
! ======================================
TUPLE: participant-changed nick action parameter ;
C: <participant-changed> participant-changed
SINGLETON: irc-chat-end ! sent to a chat to stop its execution
SINGLETON: irc-end ! sent when the client isn't running anymore
SINGLETON: irc-disconnected ! sent when connection is lost
SINGLETON: irc-connected ! sent when connection is established
: terminate-irc ( irc-client -- )
[ is-running>> ] keep and [
f >>is-running
[ stream>> dispose ] keep
[ in-messages>> ] [ out-messages>> ] bi 2array
[ irc-end swap mailbox-put ] each
] when* ;
<PRIVATE
SYMBOL: current-irc-client
! ======================================
! Utils
! ======================================
: irc> ( -- irc-client ) current-irc-client get ;
: irc-write ( s -- ) irc> stream>> stream-write ;
: irc-print ( s -- ) irc> stream>> [ stream-print ] keep stream-flush ;
: irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ;
: chat> ( name -- chat/f ) irc> chats>> at ;
: channel-mode? ( mode -- ? ) name>> first "#&" member? ;
: me? ( string -- ? ) irc> nick>> = ;
GENERIC: to-chat ( message obj -- )
M: string to-chat
chat> [ +server-chat+ chat> ] unless*
[ to-chat ] [ drop ] if* ;
M: irc-chat to-chat in-messages>> mailbox-put ;
: unregister-chat ( name -- )
irc> chats>>
[ at [ irc-chat-end ] dip to-chat ]
[ delete-at ]
2bi ;
: (remove-participant) ( nick chat -- )
[ participants>> delete-at ]
[ [ +part+ f <participant-changed> ] dip to-chat ] 2bi ;
: remove-participant ( nick channel -- )
chat> [ (remove-participant) ] [ drop ] if* ;
: chats-with-participant ( nick -- seq )
irc> chats>> values
[ [ irc-channel-chat? ] keep and [ participants>> key? ] [ drop f ] if* ]
with filter ;
: to-chats-with-participant ( message nickname -- )
chats-with-participant [ to-chat ] with each ;
: remove-participant-from-all ( nick -- )
dup chats-with-participant [ (remove-participant) ] with each ;
: notify-rename ( newnick oldnick chat -- )
[ participant-changed new +nick+ >>action
[ (>>nick) ] [ (>>parameter) ] [ ] tri ] dip to-chat ;
: rename-participant ( newnick oldnick chat -- )
[ participants>> [ delete-at* drop ] [ swapd set-at ] bi ]
[ notify-rename ] 3bi ;
: rename-participant-in-all ( oldnick newnick -- )
swap dup chats-with-participant [ rename-participant ] with with each ;
: add-participant ( mode nick channel -- )
chat>
[ participants>> set-at ]
[ [ +join+ f <participant-changed> ] dip to-chat ] 2bi ;
: change-participant-mode ( channel mode nick -- )
rot chat>
[ participants>> set-at ]
[ [ participant-changed new
[ (>>nick) ] [ (>>parameter) ] [ +mode+ >>action ] tri ] dip to-chat ]
3bi ; ! FIXME
! ======================================
! IRC client messages
! ======================================
: /NICK ( nick -- )
"NICK " irc-write irc-print ;
: /LOGIN ( nick -- )
dup /NICK
"USER " irc-write irc-write
" hostname servername :irc.factor" irc-print ;
: /CONNECT ( server port -- stream )
irc> connect>> call drop ; inline
: /JOIN ( channel password -- )
"JOIN " irc-write
[ [ " :" ] dip 3append ] when* irc-print ;
: /PONG ( text -- )
"PONG " irc-write irc-print ;
! ======================================
! Server message handling
! ======================================
GENERIC: initialize-chat ( chat -- )
M: irc-chat initialize-chat drop ;
M: irc-channel-chat initialize-chat [ name>> ] [ password>> ] bi /JOIN ;
GENERIC: forward-name ( irc-message -- name )
M: join forward-name trailing>> ;
M: part forward-name channel>> ;
M: kick forward-name channel>> ;
M: mode forward-name name>> ;
M: privmsg forward-name dup name>> me? [ irc-message-sender ] [ name>> ] if ;
UNION: single-forward join part kick mode privmsg ;
UNION: multiple-forward nick quit ;
UNION: broadcast-forward irc-end irc-disconnected irc-connected ;
GENERIC: forward-message ( irc-message -- )
M: irc-message forward-message
+server-chat+ chat> [ to-chat ] [ drop ] if* ;
M: single-forward forward-message dup forward-name to-chat ;
M: multiple-forward forward-message
dup irc-message-sender to-chats-with-participant ;
M: broadcast-forward forward-message
irc> chats>> values [ to-chat ] with each ;
GENERIC: process-message ( irc-message -- )
M: object process-message drop ;
M: logged-in process-message
name>> t irc> [ (>>is-ready) ] [ (>>nick) ] [ chats>> ] tri
values [ initialize-chat ] each ;
M: ping process-message trailing>> /PONG ;
M: nick-in-use process-message name>> "_" append /NICK ;
M: join process-message
[ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri
dup chat> [ add-participant ] [ 3drop ] if ;
M: part process-message
[ irc-message-sender ] [ channel>> ] bi remove-participant ;
M: kick process-message
[ [ who>> ] [ channel>> ] bi remove-participant ]
[ dup who>> me? [ unregister-chat ] [ drop ] if ]
bi ;
M: quit process-message
irc-message-sender remove-participant-from-all ;
M: nick process-message
[ irc-message-sender ] [ trailing>> ] bi rename-participant-in-all ;
M: mode process-message ( mode -- )
[ channel-mode? ] keep and [
[ name>> ] [ mode>> ] [ parameter>> ] tri
[ change-participant-mode ] [ 2drop ] if*
] when* ;
: >nick/mode ( string -- nick mode )
dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ;
: names-reply>participants ( names-reply -- participants )
trailing>> [ blank? ] trim " " split
[ >nick/mode 2array ] map >hashtable ;
: maybe-clean-participants ( channel-chat -- )
dup clean-participants>> [
H{ } clone >>participants f >>clean-participants
] when drop ;
M: names-reply process-message
[ names-reply>participants ] [ channel>> chat> ] bi [
[ maybe-clean-participants ]
[ participants>> 2array assoc-combine ]
[ (>>participants) ] tri
] [ drop ] if* ;
M: end-of-names process-message
channel>> chat> [
t >>clean-participants
[ f f f <participant-changed> ] dip name>> to-chat
] when* ;
! ======================================
! Client message handling
! ======================================
GENERIC: handle-outgoing-irc ( irc-message -- ? )
M: irc-end handle-outgoing-irc drop f ;
M: irc-message handle-outgoing-irc irc-message>client-line irc-print t ;
! ======================================
! Reader/Writer
! ======================================
: handle-reader-message ( irc-message -- )
irc> in-messages>> mailbox-put ;
DEFER: (connect-irc)
: (handle-disconnect) ( -- )
irc>
[ [ irc-disconnected ] dip in-messages>> mailbox-put ]
[ dup reconnect-time>> sleep (connect-irc) ]
[ nick>> /LOGIN ]
tri ;
! FIXME: do something with the exception, store somewhere to help debugging
: handle-disconnect ( error -- ? )
drop irc> is-running>> [ (handle-disconnect) t ] [ f ] if ;
: (reader-loop) ( -- ? )
irc> stream>> [
|dispose stream-readln [
parse-irc-line handle-reader-message t
] [
handle-disconnect
] if*
] with-destructors ;
: reader-loop ( -- ? )
[ (reader-loop) ] [ handle-disconnect ] recover ;
: writer-loop ( -- ? )
irc> out-messages>> mailbox-get handle-outgoing-irc ;
! ======================================
! Processing loops
! ======================================
: in-multiplexer-loop ( -- ? )
irc> in-messages>> mailbox-get
[ forward-message ] [ process-message ] [ irc-end? not ] tri ;
: strings>privmsg ( name string -- privmsg )
privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ;
: maybe-annotate-with-name ( name obj -- obj )
{ { [ dup string? ] [ strings>privmsg ] }
{ [ dup privmsg instance? ] [ swap >>name ] }
[ nip ]
} cond ;
GENERIC: annotate-message ( chat object -- object )
M: object annotate-message nip ;
M: part annotate-message swap name>> >>channel ;
M: privmsg annotate-message swap name>> >>name ;
M: string annotate-message [ name>> ] dip strings>privmsg ;
: spawn-irc ( -- )
[ reader-loop ] "irc-reader-loop" spawn-server
[ writer-loop ] "irc-writer-loop" spawn-server
[ in-multiplexer-loop ] "in-multiplexer-loop" spawn-server
3drop ;
GENERIC: (attach-chat) ( irc-chat -- )
USE: prettyprint
M: irc-chat (attach-chat)
[ [ irc> >>client ] [ name>> ] bi irc> chats>> set-at ]
[ [ irc> is-ready>> ] dip and [ initialize-chat ] when* ]
bi ;
M: irc-server-chat (attach-chat)
irc> >>client +server-chat+ irc> chats>> set-at ;
GENERIC: (remove-chat) ( irc-chat -- )
M: irc-nick-chat (remove-chat)
name>> unregister-chat ;
M: irc-channel-chat (remove-chat)
[ part new annotate-message irc> out-messages>> mailbox-put ] keep
name>> unregister-chat ;
M: irc-server-chat (remove-chat)
drop +server-chat+ unregister-chat ;
: (connect-irc) ( irc-client -- )
{
[ profile>> [ server>> ] [ port>> ] bi /CONNECT ]
[ (>>stream) ]
[ t swap (>>is-running) ]
[ in-messages>> [ irc-connected ] dip mailbox-put ]
} cleave ;
: with-irc-client ( irc-client quot: ( -- ) -- )
[ \ current-irc-client ] dip with-variable ; inline
PRIVATE>
: connect-irc ( irc-client -- )
dup [ [ (connect-irc) ] [ nick>> /LOGIN ] bi spawn-irc ] with-irc-client ;
: attach-chat ( irc-chat irc-client -- ) [ (attach-chat) ] with-irc-client ;
: detach-chat ( irc-chat -- )
[ client>> ] keep '[ _ (remove-chat) ] with-irc-client ;
: speak ( message irc-chat -- )
[ swap annotate-message ] [ client>> out-messages>> mailbox-put ] bi ;
[ (connect-irc) (do-login) spawn-irc ] with-irc ;
: attach-chat ( irc-chat irc-client -- ) [ (attach-chat) ] with-irc ;
: detach-chat ( irc-chat -- ) dup [ client>> remove-chat ] with-irc ;
: speak ( message irc-chat -- ) dup client>> [ (speak) ] with-irc ;
: hear ( irc-chat -- message ) in-messages>> mailbox-get ;
: terminate-irc ( irc-client -- ) [ (terminate-irc) ] with-irc ;

1
extra/irc/client/internals/authors.txt Normal file
View File

@ -0,0 +1 @@
Bruno Deferrari

195
extra/irc/client/client-tests.factor → extra/irc/client/internals/internals-tests.factor
View File

@ -1,10 +1,13 @@
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: kernel tools.test accessors arrays sequences
io io.streams.duplex namespaces threads destructors
calendar irc.client.private irc.client irc.messages.private
concurrency.mailboxes classes assocs combinators ;
io io.streams.duplex namespaces threads destructors
calendar concurrency.mailboxes classes assocs combinators
irc.messages.parser irc.client.base irc.client.chats
irc.client.participants irc.client.internals ;
EXCLUDE: irc.messages => join ;
RENAME: join irc.messages => join_
IN: irc.client.tests
IN: irc.client.internals.tests
! Streams for testing
TUPLE: mb-writer lines last-line disposed ;
@ -28,18 +31,20 @@ M: mb-writer dispose drop ;
t >>is-ready
t >>is-running
<test-stream> >>stream
dup [ spawn-irc yield ] with-irc-client ;
dup [ spawn-irc yield ] with-irc ;
! to be used inside with-irc-client quotations
: %add-named-chat ( chat -- ) irc> attach-chat ;
! to be used inside with-irc quotations
: %add-named-chat ( chat -- ) (attach-chat) ;
: %push-line ( line -- ) irc> stream>> in>> push-line yield ;
: %join ( channel -- ) <irc-channel-chat> irc> attach-chat ;
: %push-lines ( lines -- ) [ %push-line ] each ;
: %join ( channel -- ) <irc-channel-chat> (attach-chat) ;
: %pop-output-line ( -- string ) irc> stream>> out>> lines>> pop ;
: read-matching-message ( chat quot: ( msg -- ? ) -- irc-message )
[ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ;
: with-irc ( quot: ( -- ) -- )
[ spawn-client ] dip [ irc> terminate-irc ] compose with-irc-client ; inline
: spawning-irc ( quot: ( -- ) -- )
[ spawn-client ] dip [ (terminate-irc) ] compose with-irc ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! TESTS
@ -49,170 +54,160 @@ M: mb-writer dispose drop ;
{ "factorbot" } [ irc> nick>> ] unit-test
{ "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
{ "#factortest" } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
parse-irc-line forward-name ] unit-test
string>irc-message chat-name ] unit-test
{ "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi"
parse-irc-line forward-name ] unit-test
] with-irc
string>irc-message chat-name ] unit-test
] spawning-irc
{ privmsg "#channel" "hello" } [
"#channel" "hello" strings>privmsg
[ class ] [ target>> ] [ trailing>> ] tri
] unit-test
! Test login and nickname set
[ { "factorbot2" } [
":some.where 001 factorbot2 :Welcome factorbot2" %push-line
irc> nick>>
] unit-test
] with-irc
] spawning-irc
! Test connect
{ V{ "NICK factorbot" "USER factorbot hostname servername :irc.factor" } } [
"someserver" irc-port "factorbot" f <irc-profile> <irc-client>
[ 2drop <test-stream> t ] >>connect
[ connect-irc ] [ stream>> out>> lines>> ] [ terminate-irc ] tri
[
(connect-irc)
(do-login)
irc> stream>> out>> lines>>
(terminate-irc)
] with-irc
] unit-test
! Test join
[ { "JOIN #factortest" } [
"#factortest" %join
irc> stream>> out>> lines>> pop
"#factortest" %join %pop-output-line
] unit-test
] with-irc
] spawning-irc
[ { join_ "#factortest" } [
[ { join_ "#factortest"} [
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
{ ":factorbot!n=factorbo@some.where JOIN :#factortest"
":ircserver.net 353 factorbot @ #factortest :@factorbot "
":ircserver.net 366 factorbot #factortest :End of /NAMES list."
":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah"
} [ %push-line ] each
in-messages>> 0.1 seconds mailbox-get-timeout
[ class ] [ trailing>> ] bi
} %push-lines
[ join? ] read-matching-message
[ class ] [ channel>> ] bi
] unit-test
] with-irc
[ { T{ participant-changed f "somebody" +join+ } } [
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
":somebody!n=somebody@some.where JOIN :#factortest" %push-line
[ participant-changed? ] read-matching-message
] unit-test
] with-irc
] spawning-irc
[ { privmsg "#factortest" "hello" } [
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
":somebody!n=somebody@some.where PRIVMSG #factortest :hello" %push-line
[ privmsg? ] read-matching-message
[ class ] [ name>> ] [ trailing>> ] tri
[ class ] [ target>> ] [ trailing>> ] tri
] unit-test
] with-irc
] spawning-irc
[ { privmsg "factorbot" "hello" } [
"ircuser" <irc-nick-chat> [ %add-named-chat ] keep
":ircuser!n=user@isp.net PRIVMSG factorbot :hello" %push-line
[ privmsg? ] read-matching-message
[ class ] [ name>> ] [ trailing>> ] tri
[ class ] [ target>> ] [ trailing>> ] tri
] unit-test
] with-irc
] spawning-irc
[ { mode } [
[ { mode "#factortest" "+ns" } [
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
":ircserver.net MODE #factortest +ns" %push-line
[ mode? ] read-matching-message class
[ mode? ] read-matching-message
[ class ] [ name>> ] [ mode>> ] tri
] unit-test
] with-irc
] spawning-irc
! Participant lists tests
[ { H{ { "ircuser" +normal+ } } } [
[ { { "ircuser" } } [
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
":ircuser!n=user@isp.net JOIN :#factortest" %push-line
participants>>
participants>> keys
] unit-test
] with-irc
] spawning-irc
[ { H{ { "ircuser2" +normal+ } } } [
[ { { "ircuser2" } } [
"#factortest" <irc-channel-chat>
H{ { "ircuser2" +normal+ }
{ "ircuser" +normal+ } } clone >>participants
{ "ircuser2" "ircuser" } [ over join-participant ] each
[ %add-named-chat ] keep
":ircuser!n=user@isp.net PART #factortest" %push-line
participants>>
participants>> keys
] unit-test
] with-irc
] spawning-irc
[ { H{ { "ircuser2" +normal+ } } } [
[ { { "ircuser2" } } [
"#factortest" <irc-channel-chat>
H{ { "ircuser2" +normal+ }
{ "ircuser" +normal+ } } clone >>participants
{ "ircuser2" "ircuser" } [ over join-participant ] each
[ %add-named-chat ] keep
":ircuser!n=user@isp.net QUIT" %push-line
participants>>
participants>> keys
] unit-test
] with-irc
] spawning-irc
[ { H{ { "ircuser2" +normal+ } } } [
[ { { "ircuser2" } } [
"#factortest" <irc-channel-chat>
H{ { "ircuser2" +normal+ }
{ "ircuser" +normal+ } } clone >>participants
{ "ircuser2" "ircuser" } [ over join-participant ] each
[ %add-named-chat ] keep
":ircuser2!n=user2@isp.net KICK #factortest ircuser" %push-line
participants>>
participants>> keys
] unit-test
] with-irc
] spawning-irc
[ { H{ { "ircuser2" +normal+ } } } [
[ { H{ { "ircuser2" T{ participant { nick "ircuser2" } } } } } [
"#factortest" <irc-channel-chat>
H{ { "ircuser" +normal+ } } clone >>participants
"ircuser" over join-participant
[ %add-named-chat ] keep
":ircuser!n=user2@isp.net NICK :ircuser2" %push-line
participants>>
] unit-test
] with-irc
] spawning-irc
[ { H{ { "factorbot" +operator+ } { "ircuser" +normal+ } } } [
[ { H{ { "factorbot" T{ participant { nick "factorbot" } { operator t } } }
{ "ircuser" T{ participant { nick "ircuser" } } }
{ "voiced" T{ participant { nick "voiced" } { voice t } } } } } [
"#factortest" <irc-channel-chat>
H{ { "ircuser" +normal+ } } clone >>participants
"ircuser" over join-participant
[ %add-named-chat ] keep
":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line
":ircserver.net 353 factorbot @ #factortest :ircuser2 " %push-line
":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line
":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line
":ircserver.net 353 factorbot @ #factortest :ircuser " %push-line
":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line
{ ":ircserver.net 353 factorbot @ #factortest :@factorbot "
":ircserver.net 353 factorbot @ #factortest :ircuser2 "
":ircserver.net 366 factorbot #factortest :End of /NAMES list."
":ircserver.net 353 factorbot @ #factortest :@factorbot +voiced "
":ircserver.net 353 factorbot @ #factortest :ircuser "
":ircserver.net 366 factorbot #factortest :End of /NAMES list."
} %push-lines
participants>>
] unit-test
] with-irc
] spawning-irc
! Namelist change notification
[ { T{ participant-changed f f f f } } [
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line
":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line
[ participant-changed? ] read-matching-message
] unit-test
] with-irc
[ { T{ participant-changed f "ircuser" +part+ f } } [
"#factortest" <irc-channel-chat>
H{ { "ircuser" +normal+ } } clone >>participants
[ %add-named-chat ] keep
":ircuser!n=user@isp.net QUIT" %push-line
[ participant-changed? ] read-matching-message
] unit-test
] with-irc
[ { T{ participant-changed f "ircuser" +nick+ "ircuser2" } } [
"#factortest" <irc-channel-chat>
H{ { "ircuser" +normal+ } } clone >>participants
[ %add-named-chat ] keep
":ircuser!n=user2@isp.net NICK :ircuser2" %push-line
[ participant-changed? ] read-matching-message
] unit-test
] with-irc
! Mode change
[ { T{ participant-changed f "ircuser" +mode+ "+o" } } [
[ { mode "#factortest" "+o" "ircuser" } [
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
"ircuser" over join-participant
":ircserver.net MODE #factortest +o ircuser" %push-line
[ participant-changed? ] read-matching-message
[ mode? ] read-matching-message
{ [ class ] [ name>> ] [ mode>> ] [ parameter>> ] } cleave
] unit-test
] with-irc
] spawning-irc
[ { T{ participant { nick "ircuser" } { operator t } } } [
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
"ircuser" over join-participant
":ircserver.net MODE #factortest +o ircuser" %push-line
participants>> "ircuser" swap at
] unit-test
] spawning-irc
! Send privmsg
[ { "PRIVMSG #factortest :hello" } [
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
"hello" swap (speak) %pop-output-line
] unit-test
] spawning-irc

162
extra/irc/client/internals/internals.factor Normal file
View File

@ -0,0 +1,162 @@
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs arrays concurrency.mailboxes continuations destructors
hashtables io irc.client.base irc.client.chats irc.messages kernel namespaces
strings words.symbol irc.messages.base irc.client.participants fry threads
combinators irc.messages.parser ;
EXCLUDE: sequences => join ;
IN: irc.client.internals
: /NICK ( nick -- ) "NICK " prepend irc-print ;
: /PONG ( text -- ) "PONG " prepend irc-print ;
: /LOGIN ( nick -- )
dup /NICK
"USER " prepend " hostname servername :irc.factor" append irc-print ;
: /CONNECT ( server port -- stream )
irc> connect>> call( host port -- stream local ) drop ;
: /JOIN ( channel password -- )
[ " :" swap 3append ] when* "JOIN " prepend irc-print ;
: (connect-irc) ( -- )
irc> {
[ profile>> [ server>> ] [ port>> ] bi /CONNECT ]
[ (>>stream) ]
[ t swap (>>is-running) ]
[ in-messages>> [ irc-connected ] dip mailbox-put ]
} cleave ;
: (do-login) ( -- ) irc> nick>> /LOGIN ;
GENERIC: initialize-chat ( chat -- )
M: irc-chat initialize-chat drop ;
M: irc-channel-chat initialize-chat [ name>> ] [ password>> ] bi /JOIN ;
GENERIC: chat-put ( message obj -- )
M: irc-chat chat-put in-messages>> mailbox-put ;
M: symbol chat-put chat> [ chat-put ] [ drop ] if* ;
M: string chat-put chat> +server-chat+ or chat-put ;
M: sequence chat-put [ chat-put ] with each ;
: delete-chat ( name -- ) irc> chats>> delete-at ;
: unregister-chat ( name -- ) [ irc-chat-end chat-put ] [ delete-chat ] bi ;
! Server message handling
GENERIC: forward-message ( irc-message -- )
M: irc-message forward-message +server-chat+ chat-put ;
M: to-one-chat forward-message dup chat> chat-put ;
M: to-all-chats forward-message chats> chat-put ;
M: to-many-chats forward-message dup sender>> participant-chats chat-put ;
GENERIC: process-message ( irc-message -- )
M: object process-message drop ;
M: ping process-message trailing>> /PONG ;
M: join process-message [ sender>> ] [ chat> ] bi join-participant ;
M: part process-message [ sender>> ] [ chat> ] bi part-participant ;
M: quit process-message sender>> quit-participant ;
M: nick process-message [ trailing>> ] [ sender>> ] bi rename-participant* ;
M: rpl-nickname-in-use process-message name>> "_" append /NICK ;
M: rpl-welcome process-message
irc>
swap nickname>> >>nick
t >>is-ready
chats>> values [ initialize-chat ] each ;
M: kick process-message
[ [ user>> ] [ chat> ] bi part-participant ]
[ dup user>> me? [ unregister-chat ] [ drop ] if ]
bi ;
M: participant-mode process-message ( participant-mode -- )
[ mode>> ] [ name>> ] [ parameter>> ] tri change-participant-mode ;
M: rpl-names process-message
[ nicks>> ] [ chat> ] bi dup ?clear-participants
'[ _ join-participant ] each ;
M: rpl-names-end process-message chat> t >>clear-participants drop ;
! Client message handling
GENERIC: handle-outgoing-irc ( irc-message -- ? )
M: irc-end handle-outgoing-irc drop f ;
M: irc-message handle-outgoing-irc irc-message>string irc-print t ;
! Reader/Writer
: handle-reader-message ( irc-message -- ) irc> in-messages>> mailbox-put ;
: (handle-disconnect) ( -- )
irc> in-messages>> irc-disconnected swap mailbox-put
irc> reconnect-time>> sleep
(connect-irc)
(do-login) ;
: handle-disconnect ( error -- ? )
[ irc> exceptions>> push ] when*
irc> is-running>> [ (handle-disconnect) t ] [ f ] if ;
GENERIC: handle-input ( line/f -- ? )
M: string handle-input string>irc-message handle-reader-message t ;
M: f handle-input handle-disconnect ;
: (reader-loop) ( -- ? )
stream> [ |dispose stream-readln handle-input ] with-destructors ;
: reader-loop ( -- ? ) [ (reader-loop) ] [ handle-disconnect ] recover ;
: writer-loop ( -- ? ) irc> out-messages>> mailbox-get handle-outgoing-irc ;
! Processing loops
: in-multiplexer-loop ( -- ? )
irc> in-messages>> mailbox-get
[ process-message ] [ forward-message ] [ irc-end? not ] tri ;
: strings>privmsg ( name string -- privmsg )
" :" prepend append "PRIVMSG " prepend string>irc-message ;
GENERIC: annotate-message ( chat object -- object )
M: object annotate-message nip ;
M: to-channel annotate-message swap name>> >>channel ;
M: to-target annotate-message swap name>> >>target ;
M: mode annotate-message swap name>> >>name ;
M: string annotate-message [ name>> ] dip strings>privmsg ;
: spawn-irc ( -- )
[ reader-loop ] "irc-reader-loop" spawn-server
[ writer-loop ] "irc-writer-loop" spawn-server
[ in-multiplexer-loop ] "in-multiplexer-loop" spawn-server
3drop ;
GENERIC: (attach-chat) ( irc-chat -- )
M: irc-chat (attach-chat)
irc>
[ [ chats>> ] [ >>client name>> swap ] 2bi set-at ]
[ is-ready>> [ initialize-chat ] [ drop ] if ]
2bi ;
M: irc-server-chat (attach-chat)
irc> [ (>>client) ] [ chats>> +server-chat+ set-at ] 2bi ;
GENERIC: remove-chat ( irc-chat -- )
M: irc-nick-chat remove-chat name>> unregister-chat ;
M: irc-server-chat remove-chat drop +server-chat+ unregister-chat ;
M: irc-channel-chat remove-chat
[ part new annotate-message irc-send ]
[ name>> unregister-chat ] bi ;
: (terminate-irc) ( -- )
irc> dup is-running>> [
f >>is-running
[ stream>> dispose ] keep
[ in-messages>> ] [ out-messages>> ] bi 2array
[ irc-end swap mailbox-put ] each
] [ drop ] if ;
: (speak) ( message irc-chat -- ) swap annotate-message irc-send ;

1
extra/irc/client/internals/summary.txt Normal file
View File

@ -0,0 +1 @@
IRC Client internals

1
extra/irc/client/participants/authors.txt Normal file
View File

@ -0,0 +1 @@
Bruno Deferrari

55
extra/irc/client/participants/participants.factor Normal file
View File

@ -0,0 +1,55 @@
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators fry hashtables
irc.client.base irc.client.chats kernel sequences splitting ;
IN: irc.client.participants
TUPLE: participant nick operator voice ;
: <participant> ( name -- participant )
{
{ [ "@" ?head ] [ t f ] }
{ [ "+" ?head ] [ f t ] }
[ f f ]
} cond participant boa ;
GENERIC: has-participant? ( name irc-chat -- ? )
M: irc-chat has-participant? 2drop f ;
M: irc-channel-chat has-participant? participants>> key? ;
: rename-X ( new old assoc quot: ( obj value -- obj ) -- )
'[ delete-at* drop swap @ ] [ nip set-at ] 3bi ; inline
: rename-nick-chat ( new old -- ) irc> chats>> [ >>name ] rename-X ;
: rename-participant ( new old chat -- ) participants>> [ >>nick ] rename-X ;
: part-participant ( nick irc-chat -- ) participants>> delete-at ;
: participant-chats ( nick -- seq ) chats> [ has-participant? ] with filter ;
: quit-participant ( nick -- )
dup participant-chats [ part-participant ] with each ;
: rename-participant* ( new old -- )
[ dup participant-chats [ rename-participant ] with with each ]
[ dup chat> [ rename-nick-chat ] [ 2drop ] if ]
2bi ;
: join-participant ( nick irc-channel-chat -- )
participants>> [ <participant> dup nick>> ] dip set-at ;
: apply-mode ( ? participant mode -- )
{
{ CHAR: o [ (>>operator) ] }
{ CHAR: v [ (>>voice) ] }
[ 3drop ]
} case ;
: apply-modes ( mode-line participant -- )
[ unclip CHAR: + = ] dip
'[ [ _ _ ] dip apply-mode ] each ;
: change-participant-mode ( mode channel nick -- )
swap chat> participants>> at apply-modes ;
: ?clear-participants ( channel-chat -- )
dup clear-participants>> [
f >>clear-participants participants>> clear-assoc
] [ drop ] if ;

1
extra/irc/client/participants/summary.txt Normal file
View File

@ -0,0 +1 @@
IRC Client chat participants handling

2
extra/irc/gitbot/gitbot.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry irc.client irc.client.private kernel namespaces
USING: fry irc.client irc.client.chats kernel namespaces
sequences threads io.encodings.8-bit io.launcher io splitting
make mason.common mason.updates calendar math alarms ;
IN: irc.gitbot

1
extra/irc/messages/base/authors.txt Normal file
View File

@ -0,0 +1 @@
Bruno Deferrari

115
extra/irc/messages/base/base.factor Normal file
View File

@ -0,0 +1,115 @@
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes.parser classes.tuple
combinators fry generic.parser kernel lexer
mirrors namespaces parser sequences splitting strings words ;
IN: irc.messages.base
TUPLE: irc-message line prefix command parameters trailing timestamp sender ;
TUPLE: unhandled < irc-message ;
SYMBOL: string-irc-type-mapping
string-irc-type-mapping [ H{ } clone ] initialize
: register-irc-message-type ( type string -- )
string-irc-type-mapping get set-at ;
: irc>type ( string -- irc-message-class )
string-irc-type-mapping get at unhandled or ;
GENERIC: irc-trailing-slot ( irc-message -- string/f )
M: irc-message irc-trailing-slot
drop f ;
GENERIC: irc-parameter-slots ( irc-message -- seq )
M: irc-message irc-parameter-slots
drop f ;
GENERIC: process-irc-trailing ( irc-message -- )
M: irc-message process-irc-trailing
dup irc-trailing-slot [
swap [ trailing>> swap ] [ <mirror> ] bi set-at
] [ drop ] if* ;
GENERIC: process-irc-prefix ( irc-message -- )
M: irc-message process-irc-prefix
drop ;
<PRIVATE
: [slot-setter] ( mirror -- quot )
'[ [ _ set-at ] [ drop ] if* ] ; inline
PRIVATE>
GENERIC: process-irc-parameters ( irc-message -- )
M: irc-message process-irc-parameters
dup irc-parameter-slots [
swap [ parameters>> swap ] [ <mirror> [slot-setter] ] bi 2each
] [ drop ] if* ;
GENERIC: post-process-irc-message ( irc-message -- )
M: irc-message post-process-irc-message drop ;
GENERIC: fill-irc-message-slots ( irc-message -- )
M: irc-message fill-irc-message-slots
{
[ process-irc-trailing ]
[ process-irc-prefix ]
[ process-irc-parameters ]
[ post-process-irc-message ]
} cleave ;
GENERIC: irc-command-string ( irc-message -- string )
M: irc-message irc-command-string drop f ;
! FIXME: inverse of post-process is missing
GENERIC: set-irc-parameters ( irc-message -- )
M: irc-message set-irc-parameters
dup irc-parameter-slots
[ over <mirror> '[ _ at ] map >>parameters ] when* drop ;
GENERIC: set-irc-trailing ( irc-message -- )
M: irc-message set-irc-trailing
dup irc-trailing-slot [ over <mirror> at >>trailing ] when* drop ;
GENERIC: set-irc-command ( irc-message -- )
M: irc-message set-irc-command
[ irc-command-string ] [ (>>command) ] bi ;
: irc-message>string ( irc-message -- string )
{
[ prefix>> ]
[ command>> ]
[ parameters>> " " join ]
[ trailing>> dup [ CHAR: : prefix ] when ]
} cleave 4array sift " " join ;
<PRIVATE
: ?define-irc-parameters ( class slot-names -- )
dup empty? not [
[ \ irc-parameter-slots create-method-in ] dip
[ [ "_" = not ] keep and ] map '[ drop _ ] define
] [ 2drop ] if ;
: ?define-irc-trailing ( class slot-name -- )
[
[ \ irc-trailing-slot create-method-in ] dip
first '[ drop _ ] define
] [ drop ] if* ;
: define-irc-class ( class params -- )
[ { ":" "_" } member? not ] filter
[ irc-message ] dip define-tuple-class ;
: define-irc-parameter-slots ( class params -- )
{ ":" } split1 [ over ] dip
[ ?define-irc-parameters ] [ ?define-irc-trailing ] 2bi* ;
PRIVATE>
#! SYNTAX:
#! IRC: type "COMMAND" slot1 ...;
#! IRC: type "COMMAND" slot1 ... : trailing-slot;
SYNTAX: IRC: ( name string parameters -- )
CREATE-CLASS
[ scan-object register-irc-message-type ] keep
";" parse-tokens
[ define-irc-class ] [ define-irc-parameter-slots ] 2bi ;

1
extra/irc/messages/base/summary.txt Normal file
View File

@ -0,0 +1 @@
IRC messages base implementation

40
extra/irc/messages/messages-tests.factor
View File

@ -1,19 +1,12 @@
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: kernel tools.test accessors arrays
irc.messages irc.messages.private ;
irc.messages.parser irc.messages ;
EXCLUDE: sequences => join ;
IN: irc.messages.tests
{ "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
{ T{ irc-message
{ line ":someuser!n=user@some.where PRIVMSG #factortest :hi" }
{ prefix "someuser!n=user@some.where" }
{ command "PRIVMSG" }
{ parameters { "#factortest" } }
{ trailing "hi" } } }
[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
string>irc-message f >>timestamp ] unit-test
! { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
{ T{ privmsg
{ line ":someuser!n=user@some.where PRIVMSG #factortest :hi" }
@ -21,18 +14,22 @@ IN: irc.messages.tests
{ command "PRIVMSG" }
{ parameters { "#factortest" } }
{ trailing "hi" }
{ name "#factortest" } } }
{ target "#factortest" }
{ text "hi" }
{ sender "someuser" } } }
[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
parse-irc-line f >>timestamp ] unit-test
string>irc-message f >>timestamp ] unit-test
{ T{ join
{ line ":someuser!n=user@some.where JOIN :#factortest" }
{ prefix "someuser!n=user@some.where" }
{ command "JOIN" }
{ parameters { } }
{ trailing "#factortest" } } }
{ trailing "#factortest" }
{ sender "someuser" }
{ channel "#factortest" } } }
[ ":someuser!n=user@some.where JOIN :#factortest"
parse-irc-line f >>timestamp ] unit-test
string>irc-message f >>timestamp ] unit-test
{ T{ mode
{ line ":ircserver.net MODE #factortest +ns" }
@ -42,7 +39,7 @@ IN: irc.messages.tests
{ name "#factortest" }
{ mode "+ns" } } }
[ ":ircserver.net MODE #factortest +ns"
parse-irc-line f >>timestamp ] unit-test
string>irc-message f >>timestamp ] unit-test
{ T{ mode
{ line ":ircserver.net MODE #factortest +o someuser" }
@ -53,18 +50,19 @@ IN: irc.messages.tests
{ mode "+o" }
{ parameter "someuser" } } }
[ ":ircserver.net MODE #factortest +o someuser"
parse-irc-line f >>timestamp ] unit-test
string>irc-message f >>timestamp ] unit-test
{ T{ nick
{ line ":someuser!n=user@some.where NICK :someuser2" }
{ prefix "someuser!n=user@some.where" }
{ command "NICK" }
{ parameters { } }
{ trailing "someuser2" } } }
{ trailing "someuser2" }
{ sender "someuser" } } }
[ ":someuser!n=user@some.where NICK :someuser2"
parse-irc-line f >>timestamp ] unit-test
string>irc-message f >>timestamp ] unit-test
{ T{ nick-in-use
{ T{ rpl-nickname-in-use
{ line ":ircserver.net 433 * nickname :Nickname is already in use" }
{ prefix "ircserver.net" }
{ command "433" }
@ -72,4 +70,4 @@ IN: irc.messages.tests
{ name "nickname" }
{ trailing "Nickname is already in use" } } }
[ ":ircserver.net 433 * nickname :Nickname is already in use"
parse-irc-line f >>timestamp ] unit-test
string>irc-message f >>timestamp ] unit-test

233
extra/irc/messages/messages.factor
View File

@ -1,179 +1,68 @@
! Copyright (C) 2008 Bruno Deferrari
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: kernel fry splitting ascii calendar accessors combinators
arrays classes.tuple math.order ;
RENAME: join sequences => sjoin
arrays classes.tuple math.order words assocs strings irc.messages.base ;
EXCLUDE: sequences => join ;
IN: irc.messages
TUPLE: irc-message line prefix command parameters trailing timestamp ;
TUPLE: logged-in < irc-message name ;
TUPLE: ping < irc-message ;
TUPLE: join < irc-message ;
TUPLE: part < irc-message channel ;
TUPLE: quit < irc-message ;
TUPLE: nick < irc-message ;
TUPLE: privmsg < irc-message name ;
TUPLE: kick < irc-message channel who ;
TUPLE: roomlist < irc-message channel names ;
TUPLE: nick-in-use < irc-message name ;
TUPLE: notice < irc-message type ;
TUPLE: mode < irc-message name mode parameter ;
TUPLE: names-reply < irc-message who channel ;
TUPLE: end-of-names < irc-message who channel ;
TUPLE: unhandled < irc-message ;
! connection
IRC: pass "PASS" password ;
IRC: nick "NICK" nickname ;
IRC: user "USER" user mode _ : realname ;
IRC: oper "OPER" name password ;
IRC: mode "MODE" name mode parameter ;
IRC: service "SERVICE" nickname _ distribution type _ : info ;
IRC: quit "QUIT" : comment ;
IRC: squit "SQUIT" server : comment ;
! channel operations
IRC: join "JOIN" : channel ;
IRC: part "PART" channel : comment ;
IRC: topic "TOPIC" channel : topic ;
IRC: names "NAMES" channel ;
IRC: list "LIST" channel ;
IRC: invite "INVITE" nickname channel ;
IRC: kick "KICK" channel user : comment ;
! chating
IRC: privmsg "PRIVMSG" target : text ;
IRC: notice "NOTICE" target : text ;
! server queries
IRC: motd "MOTD" target ;
IRC: lusers "LUSERS" mask target ;
IRC: version "VERSION" target ;
IRC: stats "STATS" query target ;
IRC: links "LINKS" server mask ;
IRC: time "TIME" target ;
IRC: connect "CONNECT" server port remote-server ;
IRC: trace "TRACE" target ;
IRC: admin "ADMIN" target ;
IRC: info "INFO" target ;
! service queries
IRC: servlist "SERVLIST" mask type ;
IRC: squery "SQUERY" service-name : text ;
! user queries
IRC: who "WHO" mask operator ;
IRC: whois "WHOIS" target mask ;
IRC: whowas "WHOWAS" nickname count target ;
! misc
IRC: kill "KILL" nickname : comment ;
IRC: ping "PING" server1 server2 ;
IRC: pong "PONG" server1 server2 ;
IRC: error "ERROR" : message ;
! numeric replies
IRC: rpl-welcome "001" nickname : comment ;
IRC: rpl-whois-user "311" nicnamek user host _ : real-name ;
IRC: rpl-channel-modes "324" channel mode params ;
IRC: rpl-notopic "331" channel : topic ;
IRC: rpl-topic "332" channel : topic ;
IRC: rpl-inviting "341" channel nickname ;
IRC: rpl-names "353" nickname _ channel : nicks ;
IRC: rpl-names-end "366" nickname channel : comment ;
! error replies
IRC: rpl-nickname-in-use "433" _ name ;
IRC: rpl-nick-collision "436" nickname : comment ;
: <irc-client-message> ( command parameters trailing -- irc-message )
irc-message new
now >>timestamp
swap >>trailing
swap >>parameters
swap >>command ;
M: rpl-names post-process-irc-message ( rpl-names -- )
[ [ blank? ] trim " " split ] change-nicks drop ;
<PRIVATE
GENERIC: command-string>> ( irc-message -- string )
M: irc-message command-string>> ( irc-message -- string ) command>> ;
M: ping command-string>> ( ping -- string ) drop "PING" ;
M: join command-string>> ( join -- string ) drop "JOIN" ;
M: part command-string>> ( part -- string ) drop "PART" ;
M: quit command-string>> ( quit -- string ) drop "QUIT" ;
M: nick command-string>> ( nick -- string ) drop "NICK" ;
M: privmsg command-string>> ( privmsg -- string ) drop "PRIVMSG" ;
M: notice command-string>> ( notice -- string ) drop "NOTICE" ;
M: mode command-string>> ( mode -- string ) drop "MODE" ;
M: kick command-string>> ( kick -- string ) drop "KICK" ;
GENERIC: command-parameters>> ( irc-message -- seq )
M: irc-message command-parameters>> ( irc-message -- seq ) parameters>> ;
M: ping command-parameters>> ( ping -- seq ) drop { } ;
M: join command-parameters>> ( join -- seq ) drop { } ;
M: part command-parameters>> ( part -- seq ) channel>> 1array ;
M: quit command-parameters>> ( quit -- seq ) drop { } ;
M: nick command-parameters>> ( nick -- seq ) drop { } ;
M: privmsg command-parameters>> ( privmsg -- seq ) name>> 1array ;
M: notice command-parameters>> ( norice -- seq ) type>> 1array ;
M: kick command-parameters>> ( kick -- seq )
[ channel>> ] [ who>> ] bi 2array ;
M: mode command-parameters>> ( mode -- seq )
[ name>> ] [ channel>> ] [ mode>> ] tri 3array ;
GENERIC# >>command-parameters 1 ( irc-message params -- irc-message )
M: irc-message >>command-parameters ( irc-message params -- irc-message )
drop ;
M: logged-in >>command-parameters ( part params -- part )
first >>name ;
M: privmsg >>command-parameters ( privmsg params -- privmsg )
first >>name ;
M: notice >>command-parameters ( notice params -- notice )
first >>type ;
M: part >>command-parameters ( part params -- part )
first >>channel ;
M: kick >>command-parameters ( kick params -- kick )
first2 [ >>channel ] [ >>who ] bi* ;
M: nick-in-use >>command-parameters ( nick-in-use params -- nick-in-use )
second >>name ;
M: names-reply >>command-parameters ( names-reply params -- names-reply )
first3 nip [ >>who ] [ >>channel ] bi* ;
M: end-of-names >>command-parameters ( names-reply params -- names-reply )
first2 [ >>who ] [ >>channel ] bi* ;
M: mode >>command-parameters ( mode params -- mode )
dup length {
{ 3 [ first3 [ >>name ] [ >>mode ] [ >>parameter ] tri* ] }
{ 2 [ first2 [ >>name ] [ >>mode ] bi* ] }
[ drop first >>name dup trailing>> >>mode ]
} case ;
PRIVATE>
GENERIC: irc-message>client-line ( irc-message -- string )
M: irc-message irc-message>client-line ( irc-message -- string )
[ command-string>> ]
[ command-parameters>> " " sjoin ]
[ trailing>> [ CHAR: : prefix ] [ "" ] if* ]
tri 3array " " sjoin ;
GENERIC: irc-message>server-line ( irc-message -- string )
M: irc-message irc-message>server-line ( irc-message -- string )
drop "not implemented yet" ;
<PRIVATE
! ======================================
! Message parsing
! ======================================
: split-at-first ( seq separators -- before after )
dupd '[ _ member? ] find [ cut 1 tail ] [ swap ] if ;
: remove-heading-: ( seq -- seq )
":" ?head drop ;
: parse-name ( string -- string )
remove-heading-: "!" split-at-first drop ;
: split-prefix ( string -- string/f string )
dup ":" head?
[ remove-heading-: " " split1 ] [ f swap ] if ;
: split-trailing ( string -- string string/f )
":" split1 ;
: copy-message-in ( command irc-message -- command )
{
[ line>> >>line ]
[ prefix>> >>prefix ]
[ command>> >>command ]
[ trailing>> >>trailing ]
[ timestamp>> >>timestamp ]
[ parameters>> [ >>parameters ] [ >>command-parameters ] bi ]
} cleave ;
PRIVATE>
UNION: sender-in-prefix privmsg join part quit kick mode nick ;
GENERIC: irc-message-sender ( irc-message -- sender )
M: sender-in-prefix irc-message-sender ( sender-in-prefix -- sender )
prefix>> parse-name ;
: string>irc-message ( string -- object )
dup split-prefix split-trailing
[ [ blank? ] trim " " split unclip swap ] dip
now irc-message boa ;
: irc-message>command ( irc-message -- command )
[
command>> {
{ "PING" [ ping ] }
{ "NOTICE" [ notice ] }
{ "001" [ logged-in ] }
{ "433" [ nick-in-use ] }
{ "353" [ names-reply ] }
{ "366" [ end-of-names ] }
{ "JOIN" [ join ] }
{ "PART" [ part ] }
{ "NICK" [ nick ] }
{ "PRIVMSG" [ privmsg ] }
{ "QUIT" [ quit ] }
{ "MODE" [ mode ] }
{ "KICK" [ kick ] }
[ drop unhandled ]
} case new
] keep copy-message-in ;
: parse-irc-line ( string -- message )
string>irc-message irc-message>command ;
PREDICATE: channel-mode < mode name>> first "#&" member? ;
PREDICATE: participant-mode < channel-mode parameter>> ;

1
extra/irc/messages/parser/authors.txt Normal file
View File

@ -0,0 +1 @@
Bruno Deferrari

35
extra/irc/messages/parser/parser.factor Normal file
View File

@ -0,0 +1,35 @@
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: kernel fry splitting ascii calendar accessors combinators
arrays classes.tuple math.order words assocs
irc.messages.base sequences ;
IN: irc.messages.parser
<PRIVATE
: split-at-first ( seq separators -- before after )
dupd '[ _ member? ] find [ cut 1 tail ] [ swap ] if ;
: split-trailing ( string -- string string/f ) ":" split1 ;
: remove-heading-: ( seq -- seq ) ":" ?head drop ;
: split-prefix ( string -- string/f string )
dup ":" head? [
remove-heading-: " " split1
] [ f swap ] if ;
: split-message ( string -- prefix command parameters trailing )
split-prefix split-trailing
[ [ blank? ] trim " " split unclip swap ] dip ;
: sender ( irc-message -- sender )
prefix>> [ remove-heading-: "!" split-at-first drop ] [ f ] if* ;
PRIVATE>
: string>irc-message ( string -- irc-message )
dup split-message
[ [ irc>type new ] [ >>command ] bi ]
[ >>parameters ]
[ >>trailing ]
tri*
[ (>>prefix) ] [ fill-irc-message-slots ] [ swap >>line ] tri
now >>timestamp dup sender >>sender ;

1
extra/irc/messages/parser/summary.txt Normal file
View File

@ -0,0 +1 @@
Basic parser for irc messages

1
extra/irc/messages/summary.txt Normal file
View File

@ -0,0 +1 @@
IRC message definitions

2
extra/mason/cleanup/cleanup.factor Normal file → Executable file
View File

@ -18,6 +18,6 @@ IN: mason.cleanup
build-dir [
compress-image
compress-test-log
"factor" delete-tree
"factor" really-delete-tree
] with-directory
] unless ;

15
extra/mason/common/common.factor Normal file → Executable file
View File

@ -2,11 +2,22 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces sequences splitting system accessors
math.functions make io io.files io.pathnames io.directories
io.launcher io.encodings.utf8 prettyprint
io.directories.hierarchy io.launcher io.encodings.utf8 prettyprint
combinators.short-circuit parser combinators calendar
calendar.format arrays mason.config locals ;
calendar.format arrays mason.config locals system ;
IN: mason.common
HOOK: really-delete-tree os ( path -- )
M: windows really-delete-tree
#! Workaround: Cygwin GIT creates read-only files for
#! some reason.
[ { "chmod" "ug+rw" "-R" } swap (normalize-path) suffix try-process ]
[ delete-tree ]
bi ;
M: unix really-delete-tree delete-tree ;
: short-running-process ( command -- )
#! Give network operations at most 15 minutes to complete.
<process>

2
extra/mason/release/archive/archive.factor Normal file → Executable file
View File

@ -29,7 +29,7 @@ IN: mason.release.archive
"-fs" "HFS+"
"-volname" "factor" }
archive-name suffix try-process
"dmg-root" delete-tree ;
"dmg-root" really-delete-tree ;
: make-unix-archive ( -- )
[ "tar" , "-cvzf" , archive-name , "factor" , ] { } make try-process ;

4
extra/mason/release/tidy/tidy.factor Normal file → Executable file
View File

@ -12,11 +12,11 @@ IN: mason.release.tidy
append ;
: remove-common-files ( -- )
common-files [ delete-tree ] each ;
common-files [ really-delete-tree ] each ;
: remove-factor-app ( -- )
target-os get "macosx" =
[ "Factor.app" delete-tree ] unless ;
[ "Factor.app" really-delete-tree ] unless ;
: tidy ( -- )
"factor" [ remove-factor-app remove-common-files ] with-directory ;

4
extra/math/analysis/analysis.factor
View File

@ -42,7 +42,7 @@ PRIVATE>
#! gamma(x) = integral 0..inf [ t^(x-1) exp(-t) ] dt
#! gamma(n+1) = n! for n > 0
dup { [ 0.0 <= ] [ 1.0 mod zero? ] } 1&& [
drop 1./0.
drop 1/0.
] [
[ abs gamma-lanczos6 ] keep dup 0 > [ drop ] [ gamma-neg ] if
] if ;
@ -51,7 +51,7 @@ PRIVATE>
#! gammaln(x) is an alternative when gamma(x)'s range
#! varies too widely
dup 0 < [
drop 1./0.
drop 1/0.
] [
[ abs gammaln-lanczos6 ] keep dup 0 > [ drop ] [ gamma-neg ] if
] if ;

1
extra/opengl/glu/authors.txt Normal file
View File

@ -0,0 +1 @@
Alex Chapman

14
basis/opengl/glu/glu.factor → extra/opengl/glu/glu.factor
View File

@ -1,8 +1,17 @@
! Copyright (C) 2005 Alex Chapman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax kernel sequences words ;
USING: alien alien.libraries alien.syntax kernel sequences words system
combinators ;
IN: opengl.glu
os {
{ [ dup macosx? ] [ drop ] }
{ [ dup windows? ] [ drop ] }
{ [ dup unix? ] [ drop "glu" "libGLU.so.1" "cdecl" add-library ] }
} cond
LIBRARY: glu
! These are defined as structs in glu.h, but we only ever use pointers to them
TYPEDEF: void* GLUnurbs*
TYPEDEF: void* GLUquadric*
@ -253,3 +262,6 @@ FUNCTION: GLint gluUnProject ( GLdouble winX, GLdouble winY, GLdouble winZ, GLdo
! FUNCTION: GLint gluBuild3DMipmaps ( GLenum target, GLint internalFormat, GLsizei width, GLsizei height, GLsizei depth, GLenum format, GLenum type, void* data ) ;
! FUNCTION: GLboolean gluCheckExtension ( GLubyte* extName, GLubyte* extString ) ;
! FUNCTION: GLint gluUnProject4 ( GLdouble winX, GLdouble winY, GLdouble winZ, GLdouble clipW, GLdouble* model, GLdouble* proj, GLint* view, GLdouble nearVal, GLdouble farVal, GLdouble* objX, GLdouble* objY, GLdouble* objZ, GLdouble* objW ) ;
: gl-look-at ( eye focus up -- )
[ first3 ] tri@ gluLookAt ;

0
basis/opengl/glu/summary.txt → extra/opengl/glu/summary.txt
View File

0
basis/opengl/glu/tags.txt → extra/opengl/glu/tags.txt
View File

191
extra/sequence-parser/sequence-parser-tests.factor Normal file
View File

@ -0,0 +1,191 @@
USING: tools.test sequence-parser ascii kernel accessors ;
IN: sequence-parser.tests
[ "hello" ]
[ "hello" [ take-rest ] parse-sequence ] unit-test
[ "hi" " how are you?" ]
[
"hi how are you?"
[ [ [ current blank? ] take-until ] [ take-rest ] bi ] parse-sequence
] unit-test
[ "foo" ";bar" ]
[
"foo;bar" [
[ CHAR: ; take-until-object ] [ take-rest ] bi
] parse-sequence
] unit-test
[ "foo " "and bar" ]
[
"foo and bar" [
[ "and" take-until-sequence ] [ take-rest ] bi
] parse-sequence
] unit-test
[ "foo " " bar" ]
[
"foo and bar" [
[ "and" take-until-sequence ]
[ "and" take-sequence drop ]
[ take-rest ] tri
] parse-sequence
] unit-test
[ "foo " " bar" ]
[
"foo and bar" [
[ "and" take-until-sequence* ]
[ take-rest ] bi
] parse-sequence
] unit-test
[ { 1 2 } ]
[ { 1 2 3 4 } <sequence-parser> { 3 4 } take-until-sequence ] unit-test
[ f "aaaa" ]
[
"aaaa" <sequence-parser>
[ "b" take-until-sequence ] [ take-rest ] bi
] unit-test
[ 6 ]
[
" foo " [ skip-whitespace n>> ] parse-sequence
] unit-test
[ { 1 2 } ]
[ { 1 2 3 } <sequence-parser> [ current 3 = ] take-until ] unit-test
[ "ab" ]
[ "abcd" <sequence-parser> "ab" take-sequence ] unit-test
[ f ]
[ "abcd" <sequence-parser> "lol" take-sequence ] unit-test
[ "ab" ]
[
"abcd" <sequence-parser>
[ "lol" take-sequence drop ] [ "ab" take-sequence ] bi
] unit-test
[ "" ]
[ "abcd" <sequence-parser> "" take-sequence ] unit-test
[ "cd" ]
[ "abcd" <sequence-parser> [ "ab" take-sequence drop ] [ "cd" take-sequence ] bi ] unit-test
[ f ]
[
"\"abc\" asdf" <sequence-parser>
[ CHAR: \ CHAR: " take-quoted-string drop ] [ "asdf" take-sequence ] bi
] unit-test
[ "abc\\\"def" ]
[
"\"abc\\\"def\" asdf" <sequence-parser>
CHAR: \ CHAR: " take-quoted-string
] unit-test
[ "asdf" ]
[
"\"abc\" asdf" <sequence-parser>
[ CHAR: \ CHAR: " take-quoted-string drop ]
[ skip-whitespace "asdf" take-sequence ] bi
] unit-test
[ f ]
[
"\"abc asdf" <sequence-parser>
CHAR: \ CHAR: " take-quoted-string
] unit-test
[ "\"abc" ]
[
"\"abc asdf" <sequence-parser>
[ CHAR: \ CHAR: " take-quoted-string drop ]
[ "\"abc" take-sequence ] bi
] unit-test
[ "c" ]
[ "c" <sequence-parser> take-token ] unit-test
[ f ]
[ "" <sequence-parser> take-token ] unit-test
[ "abcd e \\\"f g" ]
[ "\"abcd e \\\"f g\"" <sequence-parser> CHAR: \ CHAR: " take-token* ] unit-test
[ "" ]
[ "" <sequence-parser> take-rest ] unit-test
[ "" ]
[ "abc" <sequence-parser> dup "abc" take-sequence drop take-rest ] unit-test
[ f ]
[ "abc" <sequence-parser> "abcdefg" take-sequence ] unit-test
[ "1234" ]
[ "1234f" <sequence-parser> take-integer ] unit-test
[ "yes" ]
[
"yes1234f" <sequence-parser>
[ take-integer drop ] [ "yes" take-sequence ] bi
] unit-test
[ f ] [ "" <sequence-parser> 4 take-n ] unit-test
[ "abcd" ] [ "abcd" <sequence-parser> 4 take-n ] unit-test
[ "abcd" "efg" ] [ "abcdefg" <sequence-parser> [ 4 take-n ] [ take-rest ] bi ] unit-test
[ "asdfasdf" ] [
"/*asdfasdf*/" <sequence-parser> take-c-comment
] unit-test
[ "k" ] [
"/*asdfasdf*/k" <sequence-parser> [ take-c-comment drop ] [ take-rest ] bi
] unit-test
[ "omg" ] [
"//asdfasdf\nomg" <sequence-parser>
[ take-c++-comment drop ] [ take-rest ] bi
] unit-test
[ "omg" ] [
"omg" <sequence-parser>
[ take-c++-comment drop ] [ take-rest ] bi
] unit-test
[ "/*asdfasdf" ] [
"/*asdfasdf" <sequence-parser> [ take-c-comment drop ] [ take-rest ] bi
] unit-test
[ "asdf" "eoieoei" ] [
"//asdf\neoieoei" <sequence-parser>
[ take-c++-comment ] [ take-rest ] bi
] unit-test
[ f "33asdf" ]
[ "33asdf" <sequence-parser> [ take-c-identifier ] [ take-rest ] bi ] unit-test
[ "asdf" ]
[ "asdf" <sequence-parser> take-c-identifier ] unit-test
[ "_asdf" ]
[ "_asdf" <sequence-parser> take-c-identifier ] unit-test
[ "_asdf400" ]
[ "_asdf400" <sequence-parser> take-c-identifier ] unit-test
[ "123" ]
[ "123jjj" <sequence-parser> take-c-integer ] unit-test
[ "123uLL" ]
[ "123uLL" <sequence-parser> take-c-integer ] unit-test
[ "123ull" ]
[ "123ull" <sequence-parser> take-c-integer ] unit-test
[ "123u" ]
[ "123u" <sequence-parser> take-c-integer ] unit-test

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