Merge branch 'master' of git://factorcode.org/git/factor
Joe Groff
commit
84008495f0
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
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 ;
|
||||
IN: bit-arrays
|
||||
|
||||
|
|
@ -70,16 +70,15 @@ M: bit-array byte-length length 7 + -3 shift ;
|
|||
|
||||
: ?{ \ } [ >bit-array ] parse-literal ; parsing
|
||||
|
||||
:: integer>bit-array ( n -- bit-array )
|
||||
n zero? [ 0 <bit-array> ] [
|
||||
[let | out [ n log2 1+ <bit-array> ] i! [ 0 ] n'! [ n ] |
|
||||
[ n' zero? ] [
|
||||
n' out underlying>> i set-alien-unsigned-1
|
||||
n' -8 shift n'!
|
||||
i 1+ i!
|
||||
] [ ] until
|
||||
out
|
||||
]
|
||||
: integer>bit-array ( n -- bit-array )
|
||||
dup 0 = [
|
||||
<bit-array>
|
||||
] [
|
||||
[ log2 1+ <bit-array> 0 ] keep
|
||||
[ dup 0 = ] [
|
||||
[ pick underlying>> pick set-alien-unsigned-1 ] keep
|
||||
[ 1+ ] [ -8 shift ] bi*
|
||||
] [ ] until 2drop
|
||||
] if ;
|
||||
|
||||
: bit-array>integer ( bit-array -- n )
|
||||
|
|
|
|||
|
|
@ -79,7 +79,7 @@ MACRO: (send) ( selector super? -- quot )
|
|||
! Runtime introspection
|
||||
SYMBOL: class-init-hooks
|
||||
|
||||
class-init-hooks [ H{ } clone or ] initialize
|
||||
class-init-hooks [ H{ } clone ] initialize
|
||||
|
||||
: (objc-class) ( name word -- class )
|
||||
2dup execute dup [ 2nip ] [
|
||||
|
|
|
|||
|
|
@ -323,4 +323,18 @@ DEFER: corner-case-1
|
|||
[ t ] [ \ corner-case-1 optimized>> ] 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
|
||||
|
|
|
|||
|
|
@ -49,7 +49,7 @@ ERROR: no-cond ;
|
|||
reverse [ no-cond ] swap alist>quot ;
|
||||
|
||||
! case
|
||||
ERROR: no-case ;
|
||||
ERROR: no-case object ;
|
||||
|
||||
: case-find ( obj assoc -- obj' )
|
||||
[
|
||||
|
|
@ -66,7 +66,7 @@ ERROR: no-case ;
|
|||
case-find {
|
||||
{ [ dup array? ] [ nip second call ] }
|
||||
{ [ dup callable? ] [ call ] }
|
||||
{ [ dup not ] [ no-case ] }
|
||||
{ [ dup not ] [ drop no-case ] }
|
||||
} cond ;
|
||||
|
||||
: linear-case-quot ( default assoc -- quot )
|
||||
|
|
|
|||
|
|
@ -1,18 +1,51 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! 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
|
||||
|
||||
TUPLE: image width height depth pitch buffer ;
|
||||
SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ;
|
||||
|
||||
TUPLE: image dim component-order bitmap ;
|
||||
|
||||
TUPLE: normalized-image < image ;
|
||||
|
||||
GENERIC: load-image* ( path tuple -- image )
|
||||
|
||||
: load-image ( path class -- image )
|
||||
new load-image* ;
|
||||
GENERIC: >image ( object -- 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 ;
|
||||
: normalize-image ( image -- image )
|
||||
normalize-component-order
|
||||
normalize-scan-line-order ;
|
||||
|
||||
: new-image ( dim component-order bitmap class -- image )
|
||||
new
|
||||
swap >>buffer
|
||||
swap >>depth
|
||||
swap >>height
|
||||
swap >>width ; inline
|
||||
swap >>bitmap
|
||||
swap >>component-order
|
||||
swap >>dim ; inline
|
||||
|
|
|
|||
|
|
@ -5,9 +5,6 @@ IN: images.bitmap.tests
|
|||
: test-bitmap24 ( -- path )
|
||||
"resource:extra/images/test-images/thiswayup24.bmp" ;
|
||||
|
||||
: test-bitmap16 ( -- path )
|
||||
"resource:extra/images/test-images/rgb16bit.bmp" ;
|
||||
|
||||
: test-bitmap8 ( -- path )
|
||||
"resource:extra/images/test-images/rgb8bit.bmp" ;
|
||||
|
||||
|
|
|
|||
|
|
@ -15,7 +15,6 @@ TUPLE: bitmap-image < image ;
|
|||
TUPLE: bitmap magic size reserved offset header-length width
|
||||
height planes bit-count compression size-image
|
||||
x-pels y-pels color-used color-important rgb-quads color-index
|
||||
alpha-channel-zero?
|
||||
buffer ;
|
||||
|
||||
: array-copy ( bitmap array -- bitmap array' )
|
||||
|
|
@ -87,23 +86,36 @@ M: bitmap-magic summary
|
|||
parse-file-header parse-bitmap-header parse-bitmap
|
||||
] with-file-reader ;
|
||||
|
||||
: alpha-channel-zero? ( bitmap -- ? )
|
||||
buffer>> 4 <sliced-groups> 3 <column> [ 0 = ] all? ;
|
||||
|
||||
: process-bitmap-data ( bitmap -- bitmap )
|
||||
dup raw-bitmap>buffer >>buffer
|
||||
dup alpha-channel-zero? >>alpha-channel-zero? ;
|
||||
dup raw-bitmap>buffer >>buffer ;
|
||||
|
||||
: load-bitmap ( path -- bitmap )
|
||||
load-bitmap-data process-bitmap-data ;
|
||||
|
||||
: bitmap>image ( bitmap -- bitmap-image )
|
||||
{ [ width>> ] [ height>> ] [ bit-count>> ] [ buffer>> ] } cleave
|
||||
bitmap-image new-image ;
|
||||
ERROR: unknown-component-order bitmap ;
|
||||
|
||||
: 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 )
|
||||
drop load-bitmap
|
||||
bitmap>image ;
|
||||
drop load-bitmap >image ;
|
||||
|
||||
M: bitmap-image normalize-scan-line-order
|
||||
dup dim>> '[
|
||||
_ first 4 * <sliced-groups> reverse concat
|
||||
] change-bitmap ;
|
||||
|
||||
MACRO: (nbits>bitmap) ( bits -- )
|
||||
[ -3 shift ] keep '[
|
||||
|
|
@ -112,7 +124,7 @@ MACRO: (nbits>bitmap) ( bits -- )
|
|||
swap >>height
|
||||
swap >>width
|
||||
swap array-copy [ >>buffer ] [ >>color-index ] bi
|
||||
_ >>bit-count bitmap>image
|
||||
_ >>bit-count >image
|
||||
] ;
|
||||
|
||||
: bgr>bitmap ( array height width -- bitmap )
|
||||
|
|
|
|||
|
|
@ -5,9 +5,17 @@ accessors images.bitmap images.tiff images.backend io.backend
|
|||
io.pathnames ;
|
||||
IN: images
|
||||
|
||||
: <image> ( path -- image )
|
||||
normalize-path dup "." split1-last nip >lower
|
||||
{
|
||||
{ "bmp" [ bitmap-image load-image ] }
|
||||
{ "tiff" [ tiff-image load-image ] }
|
||||
ERROR: unknown-image-extension extension ;
|
||||
|
||||
: image-class ( path -- class )
|
||||
file-extension >lower {
|
||||
{ "bmp" [ bitmap-image ] }
|
||||
{ "tiff" [ tiff-image ] }
|
||||
[ unknown-image-extension ]
|
||||
} case ;
|
||||
|
||||
: load-image ( path -- image )
|
||||
dup image-class new load-image* ;
|
||||
|
||||
: <image> ( path -- image )
|
||||
load-image normalize-image ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
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
|
||||
io.binary assocs math math.bitwise byte-arrays grouping
|
||||
images.backend ;
|
||||
|
|
@ -13,7 +13,7 @@ TUPLE: parsed-tiff endianness the-answer ifd-offset ifds ;
|
|||
CONSTRUCTOR: parsed-tiff ( -- tiff ) V{ } clone >>ifds ;
|
||||
|
||||
TUPLE: ifd count ifd-entries next
|
||||
processed-tags strips buffer ;
|
||||
processed-tags strips bitmap ;
|
||||
CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ;
|
||||
|
||||
TUPLE: ifd-entry tag type count offset/value ;
|
||||
|
|
@ -257,29 +257,37 @@ ERROR: bad-small-ifd-type n ;
|
|||
dup ifd-entries>>
|
||||
[ process-ifd-entry swap ] H{ } map>assoc >>processed-tags ;
|
||||
|
||||
: strips>buffer ( ifd -- ifd )
|
||||
dup strips>> concat >>buffer ;
|
||||
: strips>bitmap ( ifd -- ifd )
|
||||
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-length find-tag ]
|
||||
[ bits-per-sample find-tag sum ]
|
||||
[ buffer>> ]
|
||||
[ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
|
||||
[ ifd-component-order ]
|
||||
[ bitmap>> ]
|
||||
} cleave tiff-image new-image ;
|
||||
|
||||
: parsed-tiff>images ( tiff -- sequence )
|
||||
ifds>> [ ifd>image ] map ;
|
||||
M: parsed-tiff >image ( image -- image )
|
||||
ifds>> [ >image ] map first ;
|
||||
|
||||
: load-tiff ( path -- parsed-tiff )
|
||||
binary [
|
||||
<parsed-tiff>
|
||||
read-header dup endianness>> [
|
||||
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-file-reader ;
|
||||
|
||||
! tiff files can store several images -- we just take the first for now
|
||||
M: tiff-image load-image* ( path tiff-image -- image )
|
||||
drop load-tiff parsed-tiff>images first ;
|
||||
drop load-tiff >image ;
|
||||
|
|
|
|||
|
|
@ -1,19 +1,19 @@
|
|||
! Copyright (C) 2007 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays combinators images.bitmap kernel math
|
||||
math.functions namespaces opengl opengl.gl ui ui.gadgets
|
||||
ui.gadgets.panes ui.render images.tiff sequences multiline
|
||||
images.backend images io.pathnames strings ;
|
||||
USING: accessors images images.backend io.pathnames kernel
|
||||
namespaces opengl opengl.gl sequences strings ui ui.gadgets
|
||||
ui.gadgets.panes ui.render ;
|
||||
IN: images.viewer
|
||||
|
||||
TUPLE: image-gadget < gadget { image image } ;
|
||||
|
||||
GENERIC: draw-image ( image -- )
|
||||
|
||||
M: image-gadget pref-dim*
|
||||
image>>
|
||||
[ width>> ] [ height>> ] bi
|
||||
[ abs ] bi@ 2array ;
|
||||
image>> dim>> ;
|
||||
|
||||
: 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 -- )
|
||||
origin get [ image>> draw-image ] with-translation ;
|
||||
|
|
@ -22,48 +22,16 @@ M: image-gadget draw-gadget* ( gadget -- )
|
|||
\ image-gadget new-gadget
|
||||
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> <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. ( object -- )
|
||||
|
||||
GENERIC: image. ( image -- )
|
||||
: default-image. ( path -- )
|
||||
<image-gadget> gadget. ;
|
||||
|
||||
M: string image. ( image -- ) <image> <image-gadget> gadget. ;
|
||||
M: string image. ( image -- ) <image> default-image. ;
|
||||
|
||||
M: pathname image. ( image -- ) <image> <image-gadget> gadget. ;
|
||||
M: pathname image. ( image -- ) <image> default-image. ;
|
||||
|
||||
M: image image. ( image -- ) <image-gadget> gadget. ;
|
||||
M: image image. ( image -- ) default-image. ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue