diff --git a/extra/images/backend/backend.factor b/extra/images/backend/backend.factor index 5e05db0f4d..fb859f31a5 100644 --- a/extra/images/backend/backend.factor +++ b/extra/images/backend/backend.factor @@ -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 [ [ 0 3 ] dip reverse-here ] each ] + [ RGBA >>component-order ] bi + ] change-bitmap + ] } + { RGB [ + [ 3 [ 255 suffix ] map concat ] change-bitmap + ] } + { BGR [ + [ + 3 dup [ [ 0 3 ] dip 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 diff --git a/extra/images/bitmap/bitmap.factor b/extra/images/bitmap/bitmap.factor index 14d52fdaf8..7b59827d02 100755 --- a/extra/images/bitmap/bitmap.factor +++ b/extra/images/bitmap/bitmap.factor @@ -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 3 [ 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 ) diff --git a/extra/images/images.factor b/extra/images/images.factor index 4b4673333f..3df7b5d2d1 100644 --- a/extra/images/images.factor +++ b/extra/images/images.factor @@ -5,8 +5,17 @@ accessors images.bitmap images.tiff images.backend io.backend io.pathnames ; IN: images -: ( 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* ; + +: ( path -- image ) + load-image normalize-image ; diff --git a/extra/images/tiff/tiff.factor b/extra/images/tiff/tiff.factor index 922e302040..dc40f648cc 100755 --- a/extra/images/tiff/tiff.factor +++ b/extra/images/tiff/tiff.factor @@ -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 [ 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 ; diff --git a/extra/images/viewer/viewer.factor b/extra/images/viewer/viewer.factor index 0b01d75748..f99c34f509 100644 --- a/extra/images/viewer/viewer.factor +++ b/extra/images/viewer/viewer.factor @@ -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 ) [ 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 -- ) gadget. ;