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

working on images protocol

db4
Doug Coleman 2009-02-10 18:42:21 -06:00
parent cf99c7afd1
commit a1e521b54e
5 changed files with 77 additions and 88 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
extra/images/backend/backend.factor
View File

@ -1,21 +1,47 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel ;
USING: accessors kernel grouping fry sequences combinators ;
IN: images.backend
SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ;
! RGBA
TUPLE: image width height depth pitch component-order buffer ;
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 component-order 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 ;
: normalize-image ( image -- image )
normalize-component-order ;
: new-image ( dim component-order bitmap class -- image )
new
swap >>buffer
swap >>bitmap
swap >>component-order
swap >>depth
swap >>height
swap >>width ; inline
swap >>dim ; inline

21
extra/images/bitmap/bitmap.factor
View File

@ -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,12 +86,8 @@ 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 ;
@ -107,13 +102,15 @@ ERROR: unknown-component-order bitmap ;
[ unknown-component-order ]
} case ;
: bitmap>image ( bitmap -- bitmap-image )
{ [ width>> ] [ height>> ] [ bit-count>> ] [ bitmap>component-order ] [ buffer>> ] } cleave
bitmap-image new-image ;
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 ;
MACRO: (nbits>bitmap) ( bits -- )
[ -3 shift ] keep '[
@ -122,7 +119,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 )

17
extra/images/images.factor
View File

@ -5,8 +5,17 @@ accessors images.bitmap images.tiff images.backend io.backend
io.pathnames ;
IN: images
: <image> ( path -- image )
dup file-extension >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 ;

24
extra/images/tiff/tiff.factor
View File

@ -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,39 +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 ;
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 ;
: ifd>image ( ifd -- image )
M: ifd >image ( ifd -- image )
{
[ image-width find-tag ]
[ image-length find-tag ]
[ bits-per-sample find-tag sum ]
[ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
[ ifd-component-order ]
[ buffer>> ]
[ 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 ;

59
extra/images/viewer/viewer.factor
View File

@ -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,50 +22,9 @@ M: image-gadget draw-gadget* ( gadget -- )
\ image-gadget new-gadget
swap >>image ;
: gl-component-order ( singletons -- n )
{
{ BGR [ GL_BGR ] }
{ RGB [ GL_BGR ] }
{ BGRA [ GL_BGRA ] }
{ RGBA [ GL_RGBA ] }
! { RGBX [ GL_RGBX ] }
! { BGRX [ GL_BGRX ] }
! { ARGB [ GL_ARGB ] }
! { ABGR [ GL_ABGR ] }
! { XRGB [ GL_XRGB ] }
! { XBGR [ GL_XBGR ] }
} 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 ]
[ component-order>> gl-component-order GL_UNSIGNED_BYTE ]
[ 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>> ]
[ component-order>> gl-component-order GL_UNSIGNED_BYTE ]
[ buffer>> ]
} cleave glDrawPixels ;
GENERIC: image. ( image -- )
M: string image. ( image -- ) <image> <image-gadget> gadget. ;