Merge branch 'master' into new_ui

db4
Slava Pestov 2009-02-10 18:52:26 -06:00
commit a62d058a83
9 changed files with 137 additions and 100 deletions

View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Slava Pestov. ! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types accessors math alien.accessors kernel USING: alien.c-types accessors math alien.accessors kernel
kernel.private locals sequences sequences.private byte-arrays kernel.private sequences sequences.private byte-arrays
parser prettyprint.custom fry ; parser prettyprint.custom fry ;
IN: bit-arrays IN: bit-arrays
@ -70,16 +70,15 @@ M: bit-array byte-length length 7 + -3 shift ;
: ?{ \ } [ >bit-array ] parse-literal ; parsing : ?{ \ } [ >bit-array ] parse-literal ; parsing
:: integer>bit-array ( n -- bit-array ) : integer>bit-array ( n -- bit-array )
n zero? [ 0 <bit-array> ] [ dup 0 = [
[let | out [ n log2 1+ <bit-array> ] i! [ 0 ] n'! [ n ] | <bit-array>
[ n' zero? ] [ ] [
n' out underlying>> i set-alien-unsigned-1 [ log2 1+ <bit-array> 0 ] keep
n' -8 shift n'! [ dup 0 = ] [
i 1+ i! [ pick underlying>> pick set-alien-unsigned-1 ] keep
] [ ] until [ 1+ ] [ -8 shift ] bi*
out ] [ ] until 2drop
]
] if ; ] if ;
: bit-array>integer ( bit-array -- n ) : bit-array>integer ( bit-array -- n )

View File

@ -323,4 +323,18 @@ DEFER: corner-case-1
[ t ] [ \ corner-case-1 optimized>> ] unit-test [ t ] [ \ corner-case-1 optimized>> ] unit-test
[ 4 ] [ 2 corner-case-1 ] unit-test [ 4 ] [ 2 corner-case-1 ] unit-test
[ 4 ] [ 2 2 [ + ] curry 1array case ] unit-test [ 4 ] [ 2 2 [ + ] curry 1array case ] unit-test
: test-case-8 ( n -- )
{
{ 1 [ "foo" ] }
} case ;
[ 3 test-case-8 ]
[ object>> 3 = ] must-fail-with
[
3 {
{ 1 [ "foo" ] }
} case
] [ object>> 3 = ] must-fail-with

View File

@ -49,7 +49,7 @@ ERROR: no-cond ;
reverse [ no-cond ] swap alist>quot ; reverse [ no-cond ] swap alist>quot ;
! case ! case
ERROR: no-case ; ERROR: no-case object ;
: case-find ( obj assoc -- obj' ) : case-find ( obj assoc -- obj' )
[ [
@ -66,7 +66,7 @@ ERROR: no-case ;
case-find { case-find {
{ [ dup array? ] [ nip second call ] } { [ dup array? ] [ nip second call ] }
{ [ dup callable? ] [ call ] } { [ dup callable? ] [ call ] }
{ [ dup not ] [ no-case ] } { [ dup not ] [ drop no-case ] }
} cond ; } cond ;
: linear-case-quot ( default assoc -- quot ) : linear-case-quot ( default assoc -- quot )

View File

@ -1,18 +1,57 @@
! Copyright (C) 2009 Doug Coleman. ! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel ; USING: accessors kernel grouping fry sequences combinators
images.bitmap math ;
IN: images.backend IN: images.backend
TUPLE: image width height depth pitch buffer ; SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ;
! RGBA
TUPLE: image dim component-order bitmap ;
TUPLE: normalized-image < image ;
GENERIC: load-image* ( path tuple -- image ) GENERIC: load-image* ( path tuple -- image )
: load-image ( path class -- image ) GENERIC: >image ( object -- image )
new load-image* ;
: new-image ( width height depth buffer class -- image ) : no-op ( -- ) ;
: normalize-component-order ( image -- image )
dup component-order>>
{
{ RGBA [ no-op ] }
{ BGRA [
[
[ 4 <sliced-groups> [ [ 0 3 ] dip <slice> reverse-here ] each ]
[ RGBA >>component-order ] bi
] change-bitmap
] }
{ RGB [
[ 3 <sliced-groups> [ 255 suffix ] map concat ] change-bitmap
] }
{ BGR [
[
3 <sliced-groups> dup [ [ 0 3 ] dip <slice> reverse-here ] each
[ 255 suffix ] map concat
] change-bitmap
] }
} case RGBA >>component-order ;
GENERIC: normalize-scan-line-order ( image -- image )
M: image normalize-scan-line-order ;
M: bitmap-image normalize-scan-line-order
dup
[ bitmap>> ] [ dim>> first 4 * ] bi <sliced-groups> reverse concat
>>bitmap ;
: normalize-image ( image -- image )
normalize-component-order
normalize-scan-line-order ;
: new-image ( dim component-order bitmap class -- image )
new new
swap >>buffer swap >>bitmap
swap >>depth swap >>component-order
swap >>height swap >>dim ; inline
swap >>width ; inline

View File

@ -5,9 +5,6 @@ IN: images.bitmap.tests
: test-bitmap24 ( -- path ) : test-bitmap24 ( -- path )
"resource:extra/images/test-images/thiswayup24.bmp" ; "resource:extra/images/test-images/thiswayup24.bmp" ;
: test-bitmap16 ( -- path )
"resource:extra/images/test-images/rgb16bit.bmp" ;
: test-bitmap8 ( -- path ) : test-bitmap8 ( -- path )
"resource:extra/images/test-images/rgb8bit.bmp" ; "resource:extra/images/test-images/rgb8bit.bmp" ;

View File

@ -15,7 +15,6 @@ TUPLE: bitmap-image < image ;
TUPLE: bitmap magic size reserved offset header-length width TUPLE: bitmap magic size reserved offset header-length width
height planes bit-count compression size-image height planes bit-count compression size-image
x-pels y-pels color-used color-important rgb-quads color-index x-pels y-pels color-used color-important rgb-quads color-index
alpha-channel-zero?
buffer ; buffer ;
: array-copy ( bitmap array -- bitmap array' ) : array-copy ( bitmap array -- bitmap array' )
@ -87,23 +86,31 @@ M: bitmap-magic summary
parse-file-header parse-bitmap-header parse-bitmap parse-file-header parse-bitmap-header parse-bitmap
] with-file-reader ; ] with-file-reader ;
: alpha-channel-zero? ( bitmap -- ? )
buffer>> 4 <sliced-groups> 3 <column> [ 0 = ] all? ;
: process-bitmap-data ( bitmap -- bitmap ) : process-bitmap-data ( bitmap -- bitmap )
dup raw-bitmap>buffer >>buffer dup raw-bitmap>buffer >>buffer ;
dup alpha-channel-zero? >>alpha-channel-zero? ;
: load-bitmap ( path -- bitmap ) : load-bitmap ( path -- bitmap )
load-bitmap-data process-bitmap-data ; load-bitmap-data process-bitmap-data ;
: bitmap>image ( bitmap -- bitmap-image ) ERROR: unknown-component-order bitmap ;
{ [ width>> ] [ height>> ] [ bit-count>> ] [ buffer>> ] } cleave
bitmap-image new-image ; : bitmap>component-order ( bitmap -- object )
bit-count>> {
{ 32 [ BGRA ] }
{ 24 [ BGR ] }
{ 8 [ BGR ] }
[ unknown-component-order ]
} case ;
M: bitmap >image ( bitmap -- bitmap-image )
{
[ [ width>> ] [ height>> ] bi 2array ]
[ bitmap>component-order ]
[ buffer>> ]
} cleave bitmap-image new-image ;
M: bitmap-image load-image* ( path bitmap -- bitmap-image ) M: bitmap-image load-image* ( path bitmap -- bitmap-image )
drop load-bitmap drop load-bitmap >image ;
bitmap>image ;
MACRO: (nbits>bitmap) ( bits -- ) MACRO: (nbits>bitmap) ( bits -- )
[ -3 shift ] keep '[ [ -3 shift ] keep '[
@ -112,7 +119,7 @@ MACRO: (nbits>bitmap) ( bits -- )
swap >>height swap >>height
swap >>width swap >>width
swap array-copy [ >>buffer ] [ >>color-index ] bi swap array-copy [ >>buffer ] [ >>color-index ] bi
_ >>bit-count bitmap>image _ >>bit-count >image
] ; ] ;
: bgr>bitmap ( array height width -- bitmap ) : bgr>bitmap ( array height width -- bitmap )

View File

@ -5,9 +5,17 @@ accessors images.bitmap images.tiff images.backend io.backend
io.pathnames ; io.pathnames ;
IN: images IN: images
: <image> ( path -- image ) ERROR: unknown-image-extension extension ;
normalize-path dup "." split1-last nip >lower
{ : image-class ( path -- class )
{ "bmp" [ bitmap-image load-image ] } file-extension >lower {
{ "tiff" [ tiff-image load-image ] } { "bmp" [ bitmap-image ] }
{ "tiff" [ tiff-image ] }
[ unknown-image-extension ]
} case ; } case ;
: load-image ( path -- image )
dup image-class new load-image* ;
: <image> ( path -- image )
load-image normalize-image ;

View File

@ -1,7 +1,7 @@
! Copyright (C) 2009 Doug Coleman. ! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators io io.encodings.binary io.files USING: accessors combinators io io.encodings.binary io.files
kernel pack endian tools.hexdump constructors sequences arrays kernel pack endian constructors sequences arrays
sorting.slots math.order math.parser prettyprint classes sorting.slots math.order math.parser prettyprint classes
io.binary assocs math math.bitwise byte-arrays grouping io.binary assocs math math.bitwise byte-arrays grouping
images.backend ; images.backend ;
@ -13,7 +13,7 @@ TUPLE: parsed-tiff endianness the-answer ifd-offset ifds ;
CONSTRUCTOR: parsed-tiff ( -- tiff ) V{ } clone >>ifds ; CONSTRUCTOR: parsed-tiff ( -- tiff ) V{ } clone >>ifds ;
TUPLE: ifd count ifd-entries next TUPLE: ifd count ifd-entries next
processed-tags strips buffer ; processed-tags strips bitmap ;
CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ; CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ;
TUPLE: ifd-entry tag type count offset/value ; TUPLE: ifd-entry tag type count offset/value ;
@ -257,29 +257,37 @@ ERROR: bad-small-ifd-type n ;
dup ifd-entries>> dup ifd-entries>>
[ process-ifd-entry swap ] H{ } map>assoc >>processed-tags ; [ process-ifd-entry swap ] H{ } map>assoc >>processed-tags ;
: strips>buffer ( ifd -- ifd ) : strips>bitmap ( ifd -- ifd )
dup strips>> concat >>buffer ; dup strips>> concat >>bitmap ;
: ifd>image ( ifd -- image ) ERROR: unknown-component-order ifd ;
: ifd-component-order ( ifd -- byte-order )
bits-per-sample find-tag sum {
{ 32 [ RGBA ] }
{ 24 [ RGB ] }
[ unknown-component-order ]
} case ;
M: ifd >image ( ifd -- image )
{ {
[ image-width find-tag ] [ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
[ image-length find-tag ] [ ifd-component-order ]
[ bits-per-sample find-tag sum ] [ bitmap>> ]
[ buffer>> ]
} cleave tiff-image new-image ; } cleave tiff-image new-image ;
: parsed-tiff>images ( tiff -- sequence ) M: parsed-tiff >image ( image -- image )
ifds>> [ ifd>image ] map ; ifds>> [ >image ] map first ;
: load-tiff ( path -- parsed-tiff ) : load-tiff ( path -- parsed-tiff )
binary [ binary [
<parsed-tiff> <parsed-tiff>
read-header dup endianness>> [ read-header dup endianness>> [
read-ifds read-ifds
dup ifds>> [ process-ifd read-strips strips>buffer drop ] each dup ifds>> [ process-ifd read-strips strips>bitmap drop ] each
] with-endianness ] with-endianness
] with-file-reader ; ] with-file-reader ;
! tiff files can store several images -- we just take the first for now ! tiff files can store several images -- we just take the first for now
M: tiff-image load-image* ( path tiff-image -- image ) M: tiff-image load-image* ( path tiff-image -- image )
drop load-tiff parsed-tiff>images first ; drop load-tiff >image ;

View File

@ -1,19 +1,19 @@
! Copyright (C) 2007 Doug Coleman. ! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators images.bitmap kernel math USING: accessors images images.backend io.pathnames kernel
math.functions namespaces opengl opengl.gl ui ui.gadgets namespaces opengl opengl.gl sequences strings ui ui.gadgets
ui.gadgets.panes ui.render images.tiff sequences multiline ui.gadgets.panes ui.render ;
images.backend images io.pathnames strings ;
IN: images.viewer IN: images.viewer
TUPLE: image-gadget < gadget { image image } ; TUPLE: image-gadget < gadget { image image } ;
GENERIC: draw-image ( image -- )
M: image-gadget pref-dim* M: image-gadget pref-dim*
image>> image>> dim>> ;
[ width>> ] [ height>> ] bi
[ abs ] bi@ 2array ; : draw-image ( tiff -- )
0 0 glRasterPos2i 1.0 -1.0 glPixelZoom
[ dim>> first2 GL_RGBA GL_UNSIGNED_BYTE ]
[ bitmap>> ] bi glDrawPixels ;
M: image-gadget draw-gadget* ( gadget -- ) M: image-gadget draw-gadget* ( gadget -- )
origin get [ image>> draw-image ] with-translation ; origin get [ image>> draw-image ] with-translation ;
@ -22,44 +22,9 @@ M: image-gadget draw-gadget* ( gadget -- )
\ image-gadget new-gadget \ image-gadget new-gadget
swap >>image ; swap >>image ;
: bits>gl-params ( n -- gl-bgr gl-format )
{
{ 32 [ GL_BGRA GL_UNSIGNED_BYTE ] }
{ 24 [ GL_BGR GL_UNSIGNED_BYTE ] }
{ 8 [ GL_BGR GL_UNSIGNED_BYTE ] }
{ 4 [ GL_BGR GL_UNSIGNED_BYTE ] }
} case ;
M: bitmap-image draw-image ( bitmap -- )
{
[
height>> dup 0 < [
drop
0 0 glRasterPos2i
1.0 -1.0 glPixelZoom
] [
0 swap abs glRasterPos2i
1.0 1.0 glPixelZoom
] if
]
[ width>> abs ]
[ height>> abs ]
[ depth>> bits>gl-params ]
[ buffer>> ]
} cleave glDrawPixels ;
: image-window ( path -- gadget ) : image-window ( path -- gadget )
[ <image> <image-gadget> dup ] [ open-window ] bi ; [ <image> <image-gadget> dup ] [ open-window ] bi ;
M: tiff-image draw-image ( tiff -- )
0 0 glRasterPos2i 1.0 -1.0 glPixelZoom
{
[ height>> ]
[ width>> ]
[ depth>> bits>gl-params ]
[ buffer>> ]
} cleave glDrawPixels ;
GENERIC: image. ( image -- ) GENERIC: image. ( image -- )
M: string image. ( image -- ) <image> <image-gadget> gadget. ; M: string image. ( image -- ) <image> <image-gadget> gadget. ;