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

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

db4
Doug Coleman 2009-03-27 21:57:27 -05:00
parent 92bd390c9b dcfb19128d
commit 4f428f6404
48 changed files with 482 additions and 232 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
Factor.app/Contents/Frameworks/libfreetype.6.dylib
View File

Binary file not shown.

9
basis/help/tips/tips-docs.factor
View File

@ -17,7 +17,14 @@ TIP: "You can write documentation for your own code using the " { $link "help" }
TIP: "You can write graphical applications using the " { $link "ui" } "." ;
TIP: "Power tools: " { $links see edit help about apropos time infer. } ;
TIP: "Tips of the day implement the " { $link "definition-protocol" } " and new tips of the day can be defined using the " { $link POSTPONE: TIP: } " parsing word." ;
HELP: TIP:
{ $syntax "TIP: content ;" }
{ $values { "content" "a markup element" } }
{ $description "Defines a new tip of the day." } ;
ARTICLE: "all-tips-of-the-day" "All tips of the day"
{ $tips-of-the-day } ;

33
basis/help/tips/tips.factor
View File

@ -1,14 +1,28 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser arrays namespaces sequences random help.markup kernel io
io.styles colors.constants ;
USING: parser arrays namespaces sequences random help.markup help.stylesheet
kernel io io.styles colors.constants definitions accessors ;
IN: help.tips
SYMBOL: tips
tips [ V{ } clone ] initialize
SYNTAX: TIP: parse-definition >array tips get push ;
TUPLE: tip < identity-tuple content loc ;
M: tip forget* tips get delq ;
M: tip where loc>> ;
M: tip set-where (>>loc) ;
: <tip> ( content -- tip ) f tip boa ;
: add-tip ( tip -- ) tips get push ;
SYNTAX: TIP:
parse-definition >array <tip>
[ save-location ] [ add-tip ] bi ;
: a-tip ( -- tip ) tips get random ;
@ -20,13 +34,20 @@ H{
{ wrap-margin 500 }
} tip-of-the-day-style set-global
: $tip-title ( tip -- )
[
heading-style get [
[ "Tip of the day" ] dip write-object
] with-style
] ($block) ;
: $tip-of-the-day ( element -- )
drop
[
tip-of-the-day-style get
[
last-element off
"Tip of the day" $heading a-tip print-element nl
a-tip [ $tip-title ] [ content>> print-element nl ] bi
"— " print-element "all-tips-of-the-day" ($link)
]
with-nesting
@ -35,4 +56,6 @@ H{
: tip-of-the-day. ( -- ) { $tip-of-the-day } print-content nl ;
: $tips-of-the-day ( element -- )
drop tips get [ nl nl ] [ print-element ] interleave ;
drop tips get [ nl nl ] [ content>> print-element ] interleave ;
INSTANCE: tip definition

4
basis/help/topics/topics.factor
View File

@ -7,8 +7,12 @@ IN: help.topics
TUPLE: link name ;
INSTANCE: link definition
MIXIN: topic
INSTANCE: link topic
INSTANCE: word topic
GENERIC: >link ( obj -- obj )

18
basis/hints/hints.factor
View File

@ -34,16 +34,18 @@ M: object specializer-declaration class ;
[ specializer-declaration ] map '[ _ declare ] pick append
] { } map>assoc ;
: specialize-quot ( quot specializer -- quot' )
specializer-cases alist>quot ;
: method-declaration ( method -- quot )
[ "method-generic" word-prop dispatch# object <array> ]
[ "method-class" word-prop ]
bi prefix ;
: specialize-method ( quot method -- quot' )
method-declaration '[ _ declare ] prepend ;
: specialize-quot ( quot specializer -- quot' )
specializer-cases alist>quot ;
[ method-declaration '[ _ declare ] prepend ]
[ "method-generic" word-prop "specializer" word-prop ] bi
[ specialize-quot ] when* ;
: standard-method? ( method -- ? )
dup method-body? [
@ -52,9 +54,11 @@ M: object specializer-declaration class ;
: specialized-def ( word -- quot )
[ def>> ] keep
[ dup standard-method? [ specialize-method ] [ drop ] if ]
[ "specializer" word-prop [ specialize-quot ] when* ]
bi ;
dup generic? [ drop ] [
[ dup standard-method? [ specialize-method ] [ drop ] if ]
[ "specializer" word-prop [ specialize-quot ] when* ]
bi
] if ;
: specialized-length ( specializer -- n )
dup [ array? ] all? [ first ] when length ;

77
basis/images/images.factor
View File

@ -1,16 +1,14 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors grouping sequences combinators
math specialized-arrays.direct.uint byte-arrays fry
specialized-arrays.direct.ushort specialized-arrays.uint
specialized-arrays.ushort specialized-arrays.float ;
USING: combinators kernel ;
IN: images
SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
SINGLETONS: L BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ;
: bytes-per-pixel ( component-order -- n )
{
{ L [ 1 ] }
{ BGR [ 3 ] }
{ RGB [ 3 ] }
{ BGRA [ 4 ] }
@ -31,71 +29,4 @@ TUPLE: image dim component-order upside-down? bitmap ;
: <image> ( -- image ) image new ; inline
GENERIC: load-image* ( path tuple -- image )
: add-dummy-alpha ( seq -- seq' )
3 <groups> [ 255 suffix ] map concat ;
: normalize-floats ( byte-array -- byte-array )
byte-array>float-array [ 255.0 * >integer ] B{ } map-as ;
GENERIC: normalize-component-order* ( image component-order -- image )
: normalize-component-order ( image -- image )
dup component-order>> '[ _ normalize-component-order* ] change-bitmap ;
M: RGBA normalize-component-order* drop ;
M: R32G32B32A32 normalize-component-order*
drop normalize-floats ;
M: R32G32B32 normalize-component-order*
drop normalize-floats add-dummy-alpha ;
: RGB16>8 ( bitmap -- bitmap' )
byte-array>ushort-array [ -8 shift ] B{ } map-as ; inline
M: R16G16B16A16 normalize-component-order*
drop RGB16>8 ;
M: R16G16B16 normalize-component-order*
drop RGB16>8 add-dummy-alpha ;
: BGR>RGB ( bitmap -- pixels )
3 <sliced-groups> [ <reversed> ] map B{ } join ; inline
: BGRA>RGBA ( bitmap -- pixels )
4 <sliced-groups>
[ unclip-last-slice [ <reversed> ] dip suffix ] map concat ; inline
M: BGRA normalize-component-order*
drop BGRA>RGBA ;
M: RGB normalize-component-order*
drop add-dummy-alpha ;
M: BGR normalize-component-order*
drop BGR>RGB add-dummy-alpha ;
: ARGB>RGBA ( bitmap -- bitmap' )
4 <groups> [ unclip suffix ] map B{ } join ; inline
M: ARGB normalize-component-order*
drop ARGB>RGBA ;
M: ABGR normalize-component-order*
drop ARGB>RGBA BGRA>RGBA ;
: normalize-scan-line-order ( image -- image )
dup upside-down?>> [
dup dim>> first 4 * '[
_ <groups> reverse concat
] change-bitmap
f >>upside-down?
] when ;
: normalize-image ( image -- image )
[ >byte-array ] change-bitmap
normalize-component-order
normalize-scan-line-order
RGBA >>component-order ;
GENERIC: load-image* ( path tuple -- image )

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

@ -1,7 +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 io.backend
accessors images.bitmap images.tiff images images.normalization
io.pathnames ;
IN: images.loader

1
basis/images/normalization/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

78
basis/images/normalization/normalization.factor Normal file
View File

@ -0,0 +1,78 @@
! Copyright (C) 2009 Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors grouping sequences combinators
math specialized-arrays.direct.uint byte-arrays fry
specialized-arrays.direct.ushort specialized-arrays.uint
specialized-arrays.ushort specialized-arrays.float images ;
IN: images.normalization
<PRIVATE
: add-dummy-alpha ( seq -- seq' )
3 <groups> [ 255 suffix ] map concat ;
: normalize-floats ( byte-array -- byte-array )
byte-array>float-array [ 255.0 * >integer ] B{ } map-as ;
GENERIC: normalize-component-order* ( image component-order -- image )
: normalize-component-order ( image -- image )
dup component-order>> '[ _ normalize-component-order* ] change-bitmap ;
M: RGBA normalize-component-order* drop ;
M: R32G32B32A32 normalize-component-order*
drop normalize-floats ;
M: R32G32B32 normalize-component-order*
drop normalize-floats add-dummy-alpha ;
: RGB16>8 ( bitmap -- bitmap' )
byte-array>ushort-array [ -8 shift ] B{ } map-as ; inline
M: R16G16B16A16 normalize-component-order*
drop RGB16>8 ;
M: R16G16B16 normalize-component-order*
drop RGB16>8 add-dummy-alpha ;
: BGR>RGB ( bitmap -- pixels )
3 <sliced-groups> [ <reversed> ] map B{ } join ; inline
: BGRA>RGBA ( bitmap -- pixels )
4 <sliced-groups>
[ unclip-last-slice [ <reversed> ] dip suffix ] map concat ; inline
M: BGRA normalize-component-order*
drop BGRA>RGBA ;
M: RGB normalize-component-order*
drop add-dummy-alpha ;
M: BGR normalize-component-order*
drop BGR>RGB add-dummy-alpha ;
: ARGB>RGBA ( bitmap -- bitmap' )
4 <groups> [ unclip suffix ] map B{ } join ; inline
M: ARGB normalize-component-order*
drop ARGB>RGBA ;
M: ABGR normalize-component-order*
drop ARGB>RGBA BGRA>RGBA ;
: normalize-scan-line-order ( image -- image )
dup upside-down?>> [
dup dim>> first 4 * '[
_ <groups> reverse concat
] change-bitmap
f >>upside-down?
] when ;
PRIVATE>
: normalize-image ( image -- image )
[ >byte-array ] change-bitmap
normalize-component-order
normalize-scan-line-order
RGBA >>component-order ;

1
basis/images/tesselation/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

46
basis/images/tesselation/tesselation-tests.factor Normal file
View File

@ -0,0 +1,46 @@
USING: images accessors kernel tools.test literals math.ranges
byte-arrays ;
IN: images.tesselation
! Check an invariant we depend on
[ t ] [
<image> B{ 1 2 3 } >>bitmap dup clone [ bitmap>> ] bi@ eq?
] unit-test
[
{
{
T{ image f { 2 2 } L f B{ 1 2 5 6 } }
T{ image f { 2 2 } L f B{ 3 4 7 8 } }
}
{
T{ image f { 2 2 } L f B{ 9 10 13 14 } }
T{ image f { 2 2 } L f B{ 11 12 15 16 } }
}
}
] [
<image>
1 16 [a,b] >byte-array >>bitmap
{ 4 4 } >>dim
L >>component-order
{ 2 2 } tesselate
] unit-test
[
{
{
T{ image f { 2 2 } L f B{ 1 2 4 5 } }
T{ image f { 1 2 } L f B{ 3 6 } }
}
{
T{ image f { 2 1 } L f B{ 7 8 } }
T{ image f { 1 1 } L f B{ 9 } }
}
}
] [
<image>
1 9 [a,b] >byte-array >>bitmap
{ 3 3 } >>dim
L >>component-order
{ 2 2 } tesselate
] unit-test

35
basis/images/tesselation/tesselation.factor Normal file
View File

@ -0,0 +1,35 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences kernel math grouping fry columns locals accessors
images math math.vectors arrays ;
IN: images.tesselation
: group-rows ( bitmap bitmap-dim -- rows )
first <sliced-groups> ; inline
: tesselate-rows ( bitmap-rows tess-dim -- bitmaps )
second <sliced-groups> ; inline
: tesselate-columns ( bitmap-rows tess-dim -- bitmaps )
first '[ _ <sliced-groups> ] map flip ; inline
: tesselate-bitmap ( bitmap bitmap-dim tess-dim -- bitmap-grid )
[ group-rows ] dip
[ tesselate-rows ] keep
'[ _ tesselate-columns ] map ;
: tile-width ( tile-bitmap original-image -- width )
[ first length ] [ component-order>> bytes-per-pixel ] bi* /i ;
: <tile-image> ( tile-bitmap original-image -- tile-image )
clone
swap
[ concat >>bitmap ]
[ [ over tile-width ] [ length ] bi 2array >>dim ] bi ;
:: tesselate ( image tess-dim -- image-grid )
image component-order>> bytes-per-pixel :> bpp
image dim>> { bpp 1 } v* :> image-dim'
tess-dim { bpp 1 } v* :> tess-dim'
image bitmap>> image-dim' tess-dim' tesselate-bitmap
[ [ image <tile-image> ] map ] map ;

22
basis/io/streams/byte-array/byte-array-tests.factor
View File

@ -1,5 +1,5 @@
USING: tools.test io.streams.byte-array io.encodings.binary
io.encodings.utf8 io kernel arrays strings ;
io.encodings.utf8 io kernel arrays strings namespaces ;
[ B{ 1 2 3 } ] [ binary [ { 1 2 3 } write ] with-byte-writer ] unit-test
[ B{ 1 2 3 } ] [ { 1 2 3 } binary [ 3 read ] with-byte-reader ] unit-test
@ -7,3 +7,23 @@ io.encodings.utf8 io kernel arrays strings ;
[ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ]
[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } utf8 [ write ] with-byte-writer ] unit-test
[ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 <byte-reader> contents dup >array swap string? ] unit-test
[ B{ 121 120 } 0 ] [
B{ 0 121 120 0 0 0 0 0 0 } binary
[ 1 read drop "\0" read-until ] with-byte-reader
] unit-test
[ 1 1 4 11 f ] [
B{ 1 2 3 4 5 6 7 8 9 10 11 12 } binary
[
read1
0 seek-absolute input-stream get stream-seek
read1
2 seek-relative input-stream get stream-seek
read1
-2 seek-end input-stream get stream-seek
read1
0 seek-end input-stream get stream-seek
read1
] with-byte-reader
] unit-test

2
basis/io/streams/byte-array/byte-array.factor
View File

@ -28,7 +28,7 @@ M: byte-reader stream-seek ( n seek-type stream -- )
swap {
{ seek-absolute [ (>>i) ] }
{ seek-relative [ [ + ] change-i drop ] }
{ seek-end [ dup underlying>> length >>i [ + ] change-i drop ] }
{ seek-end [ [ underlying>> length + ] keep (>>i) ] }
[ bad-seek-type ]
} case ;

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

@ -37,7 +37,7 @@ IN: math.bitwise
! flags
MACRO: flags ( values -- )
[ 0 ] [ [ dup word? [ execute ] when bitor ] curry compose ] reduce ;
[ 0 ] [ [ ?execute bitor ] curry compose ] reduce ;
! bitfield
<PRIVATE

4
basis/opengl/opengl-docs.factor
View File

@ -23,11 +23,11 @@ HELP: gl-line
{ $description "Draws a line between two points." } ;
HELP: gl-fill-rect
{ $values { "dim" "a pair of integers" } }
{ $values { "loc" "a pair of integers" } { "dim" "a pair of integers" } }
{ $description "Draws a filled rectangle with the top-left corner at the origin and the given dimensions." } ;
HELP: gl-rect
{ $values { "dim" "a pair of integers" } }
{ $values { "loc" "a pair of integers" } { "dim" "a pair of integers" } }
{ $description "Draws the outline of a rectangle with the top-left corner at the origin and the given dimensions." } ;
HELP: gen-gl-buffer

48
basis/opengl/opengl.factor
View File

@ -3,8 +3,8 @@
! 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 arrays sequences splitting words byte-arrays assocs
namespaces math.vectors math.parser opengl.gl opengl.glu combinators
combinators.smart arrays sequences splitting words byte-arrays assocs
colors colors.constants accessors generalizations locals fry
specialized-arrays.float specialized-arrays.uint ;
IN: opengl
@ -28,7 +28,7 @@ IN: opengl
over glEnableClientState dip glDisableClientState ; inline
: words>values ( word/value-seq -- value-seq )
[ dup word? [ execute ] when ] map ;
[ ?execute ] map ;
: (all-enabled) ( seq quot -- )
over [ glEnable ] each dip [ glDisable ] each ; inline
@ -67,42 +67,46 @@ MACRO: all-enabled-client-state ( seq quot -- )
: gl-line ( a b -- )
line-vertices GL_LINES 0 2 glDrawArrays ;
: (rect-vertices) ( dim -- vertices )
:: (rect-vertices) ( loc dim -- vertices )
#! We use GL_LINE_STRIP with a duplicated first vertex
#! instead of GL_LINE_LOOP to work around a bug in Apple's
#! X3100 driver.
{
[ drop 0.5 0.5 ]
[ first 0.3 - 0.5 ]
[ [ first 0.3 - ] [ second 0.3 - ] bi ]
[ second 0.3 - 0.5 swap ]
[ drop 0.5 0.5 ]
} cleave 10 float-array{ } nsequence ;
loc first2 :> y :> x
dim first2 :> h :> w
[
x 0.5 + y 0.5 +
x w + 0.3 - y 0.5 +
x w + 0.3 - y h + 0.3 -
x y h + 0.3 -
x 0.5 + y 0.5 +
] float-array{ } output>sequence ;
: rect-vertices ( dim -- )
: rect-vertices ( loc dim -- )
(rect-vertices) gl-vertex-pointer ;
: (gl-rect) ( -- )
GL_LINE_STRIP 0 5 glDrawArrays ;
: gl-rect ( dim -- )
: gl-rect ( loc dim -- )
rect-vertices (gl-rect) ;
: (fill-rect-vertices) ( dim -- vertices )
{
[ drop 0 0 ]
[ first 0 ]
[ first2 ]
[ second 0 swap ]
} cleave 8 float-array{ } nsequence ;
:: (fill-rect-vertices) ( loc dim -- vertices )
loc first2 :> y :> x
dim first2 :> h :> w
[
x y
x w + y
x w + y h +
x y h +
] float-array{ } output>sequence ;
: fill-rect-vertices ( dim -- )
: fill-rect-vertices ( loc dim -- )
(fill-rect-vertices) gl-vertex-pointer ;
: (gl-fill-rect) ( -- )
GL_QUADS 0 4 glDrawArrays ;
: gl-fill-rect ( dim -- )
: gl-fill-rect ( loc dim -- )
fill-rect-vertices (gl-fill-rect) ;
: do-attribs ( bits quot -- )

16
basis/opengl/textures/textures-tests.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test opengl.textures opengl.textures.private
images kernel namespaces ;
opengl.textures.private images kernel namespaces accessors
sequences ;
IN: opengl.textures.tests
[ ] [
@ -52,4 +53,17 @@ IN: opengl.textures.tests
{ component-order R32G32B32 }
{ bitmap B{ } }
} power-of-2-image
] unit-test
[
{
{ { 0 0 } { 10 0 } }
{ { 0 20 } { 10 20 } }
}
] [
{
{ { 10 20 } { 30 20 } }
{ { 10 30 } { 30 300 } }
}
[ [ image new swap >>dim ] map ] map image-locs
] unit-test

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

@ -1,16 +1,15 @@
! 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 grouping specialized-arrays.float
locals sequences math math.vectors generalizations ;
opengl opengl.gl combinators images images.tesselation grouping
specialized-arrays.float locals sequences math math.vectors
math.matrices generalizations fry columns ;
IN: opengl.textures
: gen-texture ( -- id ) [ glGenTextures ] (gen-gl-object) ;
: delete-texture ( id -- ) [ glDeleteTextures ] (delete-gl-object) ;
TUPLE: texture loc dim texture-coords texture display-list disposed ;
GENERIC: component-order>format ( component-order -- format type )
M: RGB component-order>format drop GL_RGB GL_UNSIGNED_BYTE ;
@ -19,8 +18,14 @@ 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 ;
GENERIC: draw-texture ( texture -- )
GENERIC: draw-scaled-texture ( dim texture -- )
<PRIVATE
TUPLE: single-texture loc dim texture-coords texture display-list disposed ;
: repeat-last ( seq n -- seq' )
over peek pad-tail concat ;
@ -69,20 +74,27 @@ M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT glTexParameteri
GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT glTexParameteri ;
: draw-textured-rect ( dim texture -- )
: with-texturing ( quot -- )
GL_TEXTURE_2D [
GL_TEXTURE_BIT [
GL_TEXTURE_COORD_ARRAY [
COLOR: white gl-color
dup loc>> [
[ [ GL_TEXTURE_2D ] dip texture>> glBindTexture ]
[ init-texture texture-coords>> gl-texture-coord-pointer ] bi
fill-rect-vertices (gl-fill-rect)
GL_TEXTURE_2D 0 glBindTexture
] with-translation
call
] do-enabled-client-state
] do-attribs
] do-enabled ;
] do-enabled ; inline
: (draw-textured-rect) ( dim texture -- )
[ loc>> ]
[ [ GL_TEXTURE_2D ] dip texture>> glBindTexture ]
[ init-texture texture-coords>> gl-texture-coord-pointer ] tri
swap gl-fill-rect ;
: draw-textured-rect ( dim texture -- )
[
(draw-textured-rect)
GL_TEXTURE_2D 0 glBindTexture
] with-texturing ;
: texture-coords ( dim -- coords )
[ dup next-power-of-2 /f ] map
@ -92,10 +104,8 @@ M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
: make-texture-display-list ( texture -- dlist )
GL_COMPILE [ [ dim>> ] keep draw-textured-rect ] make-dlist ;
PRIVATE>
: <texture> ( image loc -- texture )
texture new swap >>loc
: <single-texture> ( image loc -- texture )
single-texture new swap >>loc
swap
[ dim>> >>dim ] keep
[ dim>> product 0 = ] keep '[
@ -105,12 +115,59 @@ PRIVATE>
dup make-texture-display-list >>display-list
] unless ;
M: texture dispose*
M: single-texture dispose*
[ texture>> [ delete-texture ] when* ]
[ display-list>> [ delete-dlist ] when* ] bi ;
: draw-texture ( texture -- )
display-list>> [ glCallList ] when* ;
M: single-texture draw-texture display-list>> [ glCallList ] when* ;
: draw-scaled-texture ( dim texture -- )
dup texture>> [ draw-textured-rect ] [ 2drop ] if ;
M: single-texture draw-scaled-texture
dup texture>> [ draw-textured-rect ] [ 2drop ] if ;
TUPLE: multi-texture grid display-list loc disposed ;
: image-locs ( image-grid -- loc-grid )
[ first [ dim>> first ] map ] [ 0 <column> [ dim>> second ] map ] bi
[ 0 [ + ] accumulate nip ] bi@
cross-zip flip ;
: <texture-grid> ( image-grid loc -- grid )
[ dup image-locs ] dip
'[ [ _ v+ <single-texture> |dispose ] 2map ] 2map ;
: draw-textured-grid ( grid -- )
[ [ [ dim>> ] keep (draw-textured-rect) ] each ] each ;
: make-textured-grid-display-list ( grid -- dlist )
GL_COMPILE [
[
[
[
[ dim>> ] keep (draw-textured-rect)
] each
] each
GL_TEXTURE_2D 0 glBindTexture
] with-texturing
] make-dlist ;
: <multi-texture> ( image-grid loc -- multi-texture )
[
[
<texture-grid> dup
make-textured-grid-display-list
] keep
f multi-texture boa
] with-destructors ;
M: multi-texture draw-texture display-list>> [ glCallList ] when* ;
M: multi-texture dispose* grid>> [ [ dispose ] each ] each ;
CONSTANT: max-texture-size { 256 256 }
PRIVATE>
: <texture> ( image loc -- texture )
over dim>> max-texture-size [ <= ] 2all?
[ <single-texture> ]
[ [ max-texture-size tesselate ] dip <multi-texture> ] if ;

12
basis/roman/roman-docs.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel math ;
USING: help.markup help.syntax kernel math strings ;
IN: roman
HELP: >roman
@ -39,7 +39,7 @@ HELP: roman>
{ >roman >ROMAN roman> } related-words
HELP: roman+
{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
{ $values { "string" string } { "string" string } { "string" string } }
{ $description "Adds two Roman numerals." }
{ $examples
{ $example "USING: io roman ;"
@ -49,7 +49,7 @@ HELP: roman+
} ;
HELP: roman-
{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
{ $values { "string" string } { "string" string } { "string" string } }
{ $description "Subtracts two Roman numerals." }
{ $examples
{ $example "USING: io roman ;"
@ -61,7 +61,7 @@ HELP: roman-
{ roman+ roman- } related-words
HELP: roman*
{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
{ $values { "string" string } { "string" string } { "string" string } }
{ $description "Multiplies two Roman numerals." }
{ $examples
{ $example "USING: io roman ;"
@ -71,7 +71,7 @@ HELP: roman*
} ;
HELP: roman/i
{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
{ $values { "string" string } { "string" string } { "string" string } }
{ $description "Computes the integer division of two Roman numerals." }
{ $examples
{ $example "USING: io roman ;"
@ -81,7 +81,7 @@ HELP: roman/i
} ;
HELP: roman/mod
{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } { "str4" "a string" } }
{ $values { "string" string } { "string" string } { "string" string } { "string" string } }
{ $description "Computes the quotient and remainder of two Roman numerals." }
{ $examples
{ $example "USING: kernel io roman ;"

6
basis/roman/roman-tests.factor
View File

@ -38,3 +38,9 @@ USING: arrays kernel math roman roman.private sequences tools.test ;
[ "iii" "iii" roman- ] must-fail
[ 30 ] [ ROMAN: xxx ] unit-test
[ roman+ ] must-infer
[ roman- ] must-infer
[ roman* ] must-infer
[ roman/i ] must-infer
[ roman/mod ] must-infer

70
basis/roman/roman.factor
View File

@ -1,29 +1,33 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs kernel math math.order math.vectors
namespaces make quotations sequences splitting.monotonic
sequences.private strings unicode.case lexer parser
grouping ;
USING: accessors arrays assocs fry generalizations grouping
kernel lexer macros make math math.order math.vectors
namespaces parser quotations sequences sequences.private
splitting.monotonic stack-checker strings unicode.case
words effects ;
IN: roman
<PRIVATE
: roman-digits ( -- seq )
{ "m" "cm" "d" "cd" "c" "xc" "l" "xl" "x" "ix" "v" "iv" "i" } ;
CONSTANT: roman-digits
{ "m" "cm" "d" "cd" "c" "xc" "l" "xl" "x" "ix" "v" "iv" "i" }
: roman-values ( -- seq )
{ 1000 900 500 400 100 90 50 40 10 9 5 4 1 } ;
CONSTANT: roman-values
{ 1000 900 500 400 100 90 50 40 10 9 5 4 1 }
ERROR: roman-range-error n ;
: roman-range-check ( n -- )
dup 1 3999 between? [ drop ] [ roman-range-error ] if ;
: roman-digit-index ( ch -- n )
1string roman-digits index ; inline
: roman<= ( ch1 ch2 -- ? )
[ 1string roman-digits index ] bi@ >= ;
[ roman-digit-index ] bi@ >= ;
: roman>n ( ch -- n )
1string roman-digits index roman-values nth ;
roman-digit-index roman-values nth ;
: (>roman) ( n -- )
roman-values roman-digits [
@ -31,47 +35,39 @@ ERROR: roman-range-error n ;
] 2each drop ;
: (roman>) ( seq -- n )
[ [ roman>n ] map ] [ all-eq? ] bi [
sum
] [
first2 swap -
] if ;
[ [ roman>n ] map ] [ all-eq? ] bi
[ sum ] [ first2 swap - ] if ;
PRIVATE>
: >roman ( n -- str )
dup roman-range-check
[ (>roman) ] "" make ;
dup roman-range-check [ (>roman) ] "" make ;
: >ROMAN ( n -- str ) >roman >upper ;
: roman> ( str -- n )
>lower [ roman<= ] monotonic-split
[ (roman>) ] sigma ;
>lower [ roman<= ] monotonic-split [ (roman>) ] sigma ;
<PRIVATE
: 2roman> ( str1 str2 -- m n )
[ roman> ] bi@ ;
: binary-roman-op ( str1 str2 quot -- str3 )
[ 2roman> ] dip call >roman ; inline
MACRO: binary-roman-op ( quot -- quot' )
dup infer [ in>> swap ] [ out>> ] bi
'[ [ roman> ] _ napply @ [ >roman ] _ napply ] ;
PRIVATE>
: roman+ ( str1 str2 -- str3 )
[ + ] binary-roman-op ;
<<
SYNTAX: ROMAN-OP:
scan-word [ name>> "roman" prepend create-in ] keep
1quotation '[ _ binary-roman-op ]
dup infer [ in>> ] [ out>> ] bi
[ "string" <repetition> ] bi@ <effect> define-declared ;
>>
: roman- ( str1 str2 -- str3 )
[ - ] binary-roman-op ;
: roman* ( str1 str2 -- str3 )
[ * ] binary-roman-op ;
: roman/i ( str1 str2 -- str3 )
[ /i ] binary-roman-op ;
: roman/mod ( str1 str2 -- str3 str4 )
[ /mod ] binary-roman-op [ >roman ] dip ;
ROMAN-OP: +
ROMAN-OP: -
ROMAN-OP: *
ROMAN-OP: /i
ROMAN-OP: /mod
SYNTAX: ROMAN: scan roman> parsed ;

6
basis/specialized-vectors/specialized-vectors-tests.factor
View File

@ -1,5 +1,9 @@
IN: specialized-vectors.tests
USING: specialized-vectors.double tools.test kernel sequences ;
USING: specialized-arrays.float
specialized-vectors.float
specialized-vectors.double
tools.test kernel sequences ;
[ 3 ] [ double-vector{ 1 2 } 3 over push length ] unit-test
[ t ] [ 10 float-array{ } new-resizable float-vector? ] unit-test

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

@ -154,6 +154,15 @@ CONSTANT: bit-member-max 256
dup sequence? [ memq-quot ] [ drop f ] if
] 1 define-transform
! Index search
\ index [
dup sequence? [
dup length 4 >= [
dup length zip >hashtable '[ _ at ]
] [ drop f ] if
] [ drop f ] if
] 1 define-transform
! Shuffling
: nths-quot ( indices -- quot )
[ [ '[ _ swap nth ] ] map ] [ length ] bi

2
basis/tools/scaffold/scaffold-docs.factor
View File

@ -26,7 +26,7 @@ HELP: scaffold-undocumented
HELP: scaffold-vocab
{ $values
{ "vocab-root" "a vocabulary root string" } { "string" string } }
{ $description "Creates a directory in the given root for a new vocabulary and adds a main .factor file, a tests file, and an authors.txt file." } ;
{ $description "Creates a directory in the given root for a new vocabulary and adds a main .factor file and an authors.txt file." } ;
HELP: scaffold-emacs
{ $description "Touches the .emacs file in your home directory and provides a clickable link to open it in an editor." } ;

2
basis/ui/gadgets/debug/debug.factor
View File

@ -58,7 +58,7 @@ M: metrics-paint draw-boundary
COLOR: red gl-color
[ dim>> ] [ >label< line-metrics ] bi
[ [ first ] [ ascent>> ] bi* [ nip 0 swap 2array ] [ 2array ] 2bi gl-line ]
[ drop gl-rect ]
[ drop { 0 0 } swap gl-rect ]
2bi ;
: <metrics-gadget> ( text font -- gadget )

9
basis/ui/gadgets/editors/editors.factor
View File

@ -172,11 +172,10 @@ TUPLE: selected-line start end first? last? ;
:: draw-selection ( line pair editor -- )
pair [ editor font>> line offset>x ] map :> pair
pair first 0 2array [
editor selection-color>> gl-color
pair second pair first - round 1 max
editor line-height 2array gl-fill-rect
] with-translation ;
editor selection-color>> gl-color
pair first 0 2array
pair second pair first - round 1 max editor line-height 2array
gl-fill-rect ;
: draw-unselected-line ( line editor -- )
font>> swap draw-text ;

3
basis/ui/gadgets/grids/grids-tests.factor
View File

@ -3,9 +3,6 @@ namespaces math.rectangles accessors ui.gadgets.grids.private
ui.gadgets.debug sequences ;
IN: ui.gadgets.grids.tests
[ { { { 1 "a" } { 1 "b" } } { { 2 "a" } { 2 "b" } } } ]
[ { 1 2 } { "a" "b" } cross-zip ] unit-test
[ { 0 0 } ] [ { } <grid> pref-dim ] unit-test
: 100x100 ( -- gadget ) <gadget> { 100 100 } >>dim ;

7
basis/ui/gadgets/grids/grids.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math math.order namespaces make sequences words io
USING: arrays kernel math math.order math.matrices namespaces make sequences words io
math.vectors ui.gadgets ui.baseline-alignment columns accessors strings.tables
math.rectangles fry ;
IN: ui.gadgets.grids
@ -33,9 +33,6 @@ PRIVATE>
<PRIVATE
: cross-zip ( seq1 seq2 -- seq1xseq2 )
[ [ 2array ] with map ] curry map ;
TUPLE: cell pref-dim baseline cap-height ;
: <cell> ( gadget -- cell )
@ -116,7 +113,7 @@ M: grid layout* [ grid>> ] [ <grid-layout> ] bi grid-layout ;
M: grid children-on ( rect gadget -- seq )
dup children>> empty? [ 2drop f ] [
{ 0 1 } swap grid>>
[ { 0 1 } ] dip grid>>
[ 0 <column> fast-children-on ] keep
<slice> concat
] if ;

4
basis/ui/gadgets/panes/panes.factor
View File

@ -79,9 +79,7 @@ GENERIC: draw-selection ( loc obj -- )
M: gadget draw-selection ( loc gadget -- )
swap offset-rect [
dup loc>> [
dim>> gl-fill-rect
] with-translation
rect-bounds gl-fill-rect
] if-fits ;
M: node draw-selection ( loc node -- )

18
basis/ui/gadgets/tables/tables.factor
View File

@ -121,16 +121,15 @@ M: table layout*
[ [ line-height ] dip * 0 swap 2array ]
[ drop [ dim>> first ] [ line-height ] bi 2array ] 2bi <rect> ;
: highlight-row ( table row color quot -- )
[ [ row-rect rect-bounds ] dip gl-color ] dip
'[ _ @ ] with-translation ; inline
: row-bounds ( table row -- loc dim )
row-rect rect-bounds ; inline
: draw-selected-row ( table -- )
{
{ [ dup selected-index>> not ] [ drop ] }
[
[ ] [ selected-index>> ] [ selection-color>> ] tri
[ gl-fill-rect ] highlight-row
[ ] [ selected-index>> ] [ selection-color>> gl-color ] tri
row-bounds gl-fill-rect
]
} cond ;
@ -139,14 +138,15 @@ M: table layout*
{ [ dup focused?>> not ] [ drop ] }
{ [ dup selected-index>> not ] [ drop ] }
[
[ ] [ selected-index>> ] [ focus-border-color>> ] tri
[ gl-rect ] highlight-row
[ ] [ selected-index>> ] [ focus-border-color>> gl-color ] tri
row-bounds gl-rect
]
} cond ;
: draw-moused-row ( table -- )
dup mouse-index>> dup [
over mouse-color>> [ gl-rect ] highlight-row
over mouse-color>> gl-color
row-bounds gl-rect
] [ 2drop ] if ;
: column-line-offsets ( table -- xs )
@ -279,7 +279,7 @@ PRIVATE>
: row-action ( table -- )
dup selected-row
[ swap [ action>> call ] [ dup hook>> call ] bi ]
[ swap [ action>> call( value -- ) ] [ dup hook>> call( table -- ) ] bi ]
[ 2drop ]
if ;

4
basis/ui/pens/solid/solid.factor
View File

@ -9,8 +9,8 @@ TUPLE: solid < caching-pen color interior-vertices boundary-vertices ;
M: solid recompute-pen
swap dim>>
[ (fill-rect-vertices) >>interior-vertices ]
[ (rect-vertices) >>boundary-vertices ]
[ [ { 0 0 } ] dip (fill-rect-vertices) >>interior-vertices ]
[ [ { 0 0 } ] dip (rect-vertices) >>boundary-vertices ]
bi drop ;
<PRIVATE

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

@ -38,7 +38,7 @@ SYMBOL: viewport-translation
! white gl-clear is broken w.r.t window resizing
! Linux/PPC Radeon 9200
COLOR: white gl-color
clip get dim>> gl-fill-rect ;
{ 0 0 } clip get dim>> gl-fill-rect ;
GENERIC: draw-gadget* ( gadget -- )

2
basis/ui/tools/operations/operations.factor
View File

@ -81,8 +81,6 @@ IN: ui.tools.operations
{ +listener+ t }
} define-operation
UNION: definition word method-spec link vocab vocab-link ;
[ definition? ] \ edit H{
{ +keyboard+ T{ key-down f { C+ } "e" } }
{ +listener+ t }

2
basis/unicode/breaks/breaks.factor
View File

@ -60,7 +60,7 @@ SYMBOL: table
: finish-table ( -- table )
table get [ [ 1 = ] map ] map ;
: eval-seq ( seq -- seq ) [ dup word? [ execute ] when ] map ;
: eval-seq ( seq -- seq ) [ ?execute ] map ;
: (set-table) ( class1 class2 val -- )
[ table get nth ] dip '[ _ or ] change-nth ;

2
core/definitions/definitions.factor
View File

@ -3,6 +3,8 @@
USING: kernel sequences namespaces assocs graphs math math.order ;
IN: definitions
MIXIN: definition
ERROR: no-compilation-unit definition ;
SYMBOLS: inlined-dependency flushed-dependency called-dependency ;

4
core/generic/generic.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors words kernel sequences namespaces make assocs
hashtables definitions kernel.private classes classes.private
@ -27,6 +27,8 @@ M: generic definition drop f ;
PREDICATE: method-spec < pair
first2 generic? swap class? and ;
INSTANCE: method-spec definition
: order ( generic -- seq )
"methods" word-prop keys sort-classes ;

9
core/io/streams/sequence/sequence.factor
View File

@ -15,11 +15,10 @@ SLOT: i
[ 1+ ] change-i drop ; inline
: sequence-read1 ( stream -- elt/f )
[ >sequence-stream< ?nth ]
[ next ] bi ; inline
[ >sequence-stream< ?nth ] [ next ] bi ; inline
: add-length ( n stream -- i+n )
[ i>> + ] [ underlying>> length ] bi min ; inline
[ i>> + ] [ underlying>> length ] bi min ; inline
: (sequence-read) ( n stream -- seq/f )
[ add-length ] keep
@ -32,8 +31,8 @@ SLOT: i
[ (sequence-read) ] [ 2drop f ] if ; inline
: find-sep ( seps stream -- sep/f n )
swap [ >sequence-stream< ] dip
[ memq? ] curry find-from swap ; inline
swap [ >sequence-stream< swap tail-slice ] dip
[ memq? ] curry find swap ; inline
: sequence-read-until ( separators stream -- seq sep/f )
[ find-sep ] keep

4
core/kernel/kernel.factor
View File

@ -23,6 +23,10 @@ GENERIC: call ( callable -- )
GENERIC: execute ( word -- )
GENERIC: ?execute ( word -- value )
M: object ?execute ;
DEFER: if
: ? ( ? true false -- true/false )

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

@ -566,8 +566,8 @@ HELP: GENERIC#
{ $description "Defines a new generic word which dispatches on the " { $snippet "n" } "th most element from the top of the stack in the current vocabulary. Initially, it contains no methods, and thus will throw a " { $link no-method } " error when called." }
{ $notes
"The following two definitions are equivalent:"
{ $code "GENERIC: foo" }
{ $code "GENERIC# foo 0" }
{ $code "GENERIC: foo ( obj -- )" }
{ $code "GENERIC# foo 0 ( obj -- )" }
} ;
HELP: MATH:

4
core/vocabs/vocabs.factor
View File

@ -108,4 +108,6 @@ SYMBOL: load-vocab-hook ! ( name -- vocab )
: load-vocab ( name -- vocab ) load-vocab-hook get call( name -- vocab ) ;
PREDICATE: runnable-vocab < vocab
vocab-main >boolean ;
vocab-main >boolean ;
INSTANCE: vocab-spec definition

4
core/words/words.factor
View File

@ -12,6 +12,8 @@ IN: words
M: word execute (execute) ;
M: word ?execute execute( -- value ) ;
M: word <=>
[ [ name>> ] [ vocabulary>> ] bi 2array ] compare ;
@ -260,3 +262,5 @@ M: word hashcode*
M: word literalize <wrapper> ;
: xref-words ( -- ) all-words [ xref ] each ;
INSTANCE: word definition

4
extra/cap/cap.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Doug Coleman, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays byte-arrays kernel math namespaces
opengl.gl sequences math.vectors ui images images.viewer
models ui.gadgets.worlds ui.gadgets fry alien.syntax ;
opengl.gl sequences math.vectors ui images images.normalization
images.viewer models ui.gadgets.worlds ui.gadgets fry alien.syntax ;
IN: cap
: screenshot-array ( world -- byte-array )

10
extra/game-input/game-input-tests.factor
View File

@ -1,8 +1,12 @@
IN: game-input.tests
USING: game-input tools.test kernel system threads ;
USING: ui game-input tools.test kernel system threads
combinators.short-circuit calendar ;
os windows? os macosx? or [
{
[ os windows? ui-running? and ]
[ os macosx? ]
} 0|| [
[ ] [ open-game-input ] unit-test
[ ] [ yield ] unit-test
[ ] [ 1 seconds sleep ] unit-test
[ ] [ close-game-input ] unit-test
] when

3
extra/math/matrices/matrices-tests.factor
View File

@ -104,3 +104,6 @@ USING: math.matrices math.vectors tools.test math ;
[ { 0 1 0 } ] [ { 0 0 1 } { 1 0 0 } cross ] unit-test
[ { 1 0 0 } ] [ { 1 1 0 } { 1 0 0 } proj ] unit-test
[ { { { 1 "a" } { 1 "b" } } { { 2 "a" } { 2 "b" } } } ]
[ { 1 2 } { "a" "b" } cross-zip ] unit-test

5
extra/math/matrices/matrices.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math math.order math.vectors sequences ;
IN: math.matrices
@ -57,3 +57,6 @@ PRIVATE>
: norm-gram-schmidt ( seq -- orthonormal )
gram-schmidt [ normalize ] map ;
: cross-zip ( seq1 seq2 -- seq1xseq2 )
[ [ 2array ] with map ] curry map ;

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

@ -8,7 +8,7 @@ IN: tetris.gl
#! OpenGL rendering for tetris
: draw-block ( block -- )
[ { 1 1 } gl-fill-rect ] with-translation ;
{ 1 1 } gl-fill-rect ;
: draw-piece-blocks ( piece -- )
piece-blocks [ draw-block ] each ;

4
extra/ui/gadgets/lists/lists.factor
View File

@ -57,9 +57,7 @@ M: list draw-gadget*
origin get [
dup color>> gl-color
selected-rect [
dup loc>> [
dim>> gl-fill-rect
] with-translation
rect-bounds gl-fill-rect
] when*
] with-translation ;