From 9060905983c9d11c7a26cce5a027278da2f08b58 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 10 Feb 2009 16:52:27 -0600 Subject: [PATCH 01/10] Fix bootstrap --- basis/cocoa/messages/messages.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index 529efeb564..ce66467203 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -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 ] [ From 8bad9f014ac500647a3c10b06956a3956f86e187 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 16:59:55 -0600 Subject: [PATCH 02/10] case now throws the value it can't find --- core/combinators/combinators-tests.factor | 16 +++++++++++++++- core/combinators/combinators.factor | 4 ++-- 2 files changed, 17 insertions(+), 3 deletions(-) diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor index 1a73e22e31..beb50f1162 100644 --- a/core/combinators/combinators-tests.factor +++ b/core/combinators/combinators-tests.factor @@ -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 \ No newline at end of file +[ 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 diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index e356a6d246..daf247d678 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -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 ) From 970953be1f3dcd874f35c131c6b00adafa43e4cf Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 17:17:36 -0600 Subject: [PATCH 03/10] fix tiff/bitmaps color order --- extra/images/backend/backend.factor | 7 +++++-- extra/images/bitmap/bitmap.factor | 12 +++++++++++- extra/images/tiff/tiff.factor | 12 +++++++++++- extra/images/viewer/viewer.factor | 20 +++++++++++++------- 4 files changed, 40 insertions(+), 11 deletions(-) diff --git a/extra/images/backend/backend.factor b/extra/images/backend/backend.factor index ef2a9a4248..5e05db0f4d 100644 --- a/extra/images/backend/backend.factor +++ b/extra/images/backend/backend.factor @@ -3,16 +3,19 @@ USING: accessors kernel ; IN: images.backend -TUPLE: image width height depth pitch buffer ; +SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ; + +TUPLE: image width height depth pitch component-order buffer ; GENERIC: load-image* ( path tuple -- image ) : load-image ( path class -- image ) new load-image* ; -: new-image ( width height depth buffer class -- image ) +: new-image ( width height depth component-order buffer class -- image ) new swap >>buffer + swap >>component-order swap >>depth swap >>height swap >>width ; inline diff --git a/extra/images/bitmap/bitmap.factor b/extra/images/bitmap/bitmap.factor index 50975b2bb3..14d52fdaf8 100755 --- a/extra/images/bitmap/bitmap.factor +++ b/extra/images/bitmap/bitmap.factor @@ -97,8 +97,18 @@ M: bitmap-magic summary : load-bitmap ( path -- bitmap ) load-bitmap-data process-bitmap-data ; +ERROR: unknown-component-order bitmap ; + +: bitmap>component-order ( bitmap -- object ) + bit-count>> { + { 32 [ BGRA ] } + { 24 [ BGR ] } + { 8 [ BGR ] } + [ unknown-component-order ] + } case ; + : bitmap>image ( bitmap -- bitmap-image ) - { [ width>> ] [ height>> ] [ bit-count>> ] [ buffer>> ] } cleave + { [ width>> ] [ height>> ] [ bit-count>> ] [ bitmap>component-order ] [ buffer>> ] } cleave bitmap-image new-image ; M: bitmap-image load-image* ( path bitmap -- bitmap-image ) diff --git a/extra/images/tiff/tiff.factor b/extra/images/tiff/tiff.factor index 4be81af095..922e302040 100755 --- a/extra/images/tiff/tiff.factor +++ b/extra/images/tiff/tiff.factor @@ -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 ; @@ -260,17 +260,27 @@ ERROR: bad-small-ifd-type n ; : strips>buffer ( ifd -- ifd ) dup strips>> concat >>buffer ; +ERROR: unknown-component-order ifd ; + +: ifd-component-order ( ifd -- byte-order ) + bits-per-sample find-tag sum { + { 32 [ RGBA ] } + [ unknown-component-order ] + } case ; + : ifd>image ( ifd -- image ) { [ image-width find-tag ] [ image-length find-tag ] [ bits-per-sample find-tag sum ] + [ ifd-component-order ] [ buffer>> ] } cleave tiff-image new-image ; : parsed-tiff>images ( tiff -- sequence ) ifds>> [ ifd>image ] map ; + : load-tiff ( path -- parsed-tiff ) binary [ diff --git a/extra/images/viewer/viewer.factor b/extra/images/viewer/viewer.factor index 4d5df4874a..0b01d75748 100644 --- a/extra/images/viewer/viewer.factor +++ b/extra/images/viewer/viewer.factor @@ -22,12 +22,18 @@ M: image-gadget draw-gadget* ( gadget -- ) \ image-gadget new-gadget swap >>image ; -: bits>gl-params ( n -- gl-bgr gl-format ) +: gl-component-order ( singletons -- n ) { - { 32 [ GL_BGRA GL_UNSIGNED_BYTE ] } - { 24 [ GL_BGR GL_UNSIGNED_BYTE ] } - { 8 [ GL_BGR GL_UNSIGNED_BYTE ] } - { 4 [ GL_BGR GL_UNSIGNED_BYTE ] } + { 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 -- ) @@ -44,7 +50,7 @@ M: bitmap-image draw-image ( bitmap -- ) ] [ width>> abs ] [ height>> abs ] - [ depth>> bits>gl-params ] + [ component-order>> gl-component-order GL_UNSIGNED_BYTE ] [ buffer>> ] } cleave glDrawPixels ; @@ -56,7 +62,7 @@ M: tiff-image draw-image ( tiff -- ) { [ height>> ] [ width>> ] - [ depth>> bits>gl-params ] + [ component-order>> gl-component-order GL_UNSIGNED_BYTE ] [ buffer>> ] } cleave glDrawPixels ; From 46bfb5c8eab23c26fd5b2b98c62db491b4253354 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 17:20:36 -0600 Subject: [PATCH 04/10] clean up --- extra/images/images.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/extra/images/images.factor b/extra/images/images.factor index eb4fc63fee..4b4673333f 100644 --- a/extra/images/images.factor +++ b/extra/images/images.factor @@ -6,8 +6,7 @@ io.pathnames ; IN: images : ( path -- image ) - normalize-path dup "." split1-last nip >lower - { + dup file-extension >lower { { "bmp" [ bitmap-image load-image ] } { "tiff" [ tiff-image load-image ] } } case ; From c2e6ef0366fde96c9cddc3141af42f5023cf80de Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 17:23:21 -0600 Subject: [PATCH 05/10] remove dead pathname --- extra/images/bitmap/bitmap-tests.factor | 3 --- 1 file changed, 3 deletions(-) diff --git a/extra/images/bitmap/bitmap-tests.factor b/extra/images/bitmap/bitmap-tests.factor index a2b3188749..a7deae3178 100644 --- a/extra/images/bitmap/bitmap-tests.factor +++ b/extra/images/bitmap/bitmap-tests.factor @@ -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" ; From cf99c7afd1bdd8e9d1d173f594b5efff6f19eac7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 17:25:02 -0600 Subject: [PATCH 06/10] no locals in bit-arrays --- basis/bit-arrays/bit-arrays.factor | 21 ++++++++++----------- 1 file changed, 10 insertions(+), 11 deletions(-) diff --git a/basis/bit-arrays/bit-arrays.factor b/basis/bit-arrays/bit-arrays.factor index f1ba71ce1e..3da22e09d6 100644 --- a/basis/bit-arrays/bit-arrays.factor +++ b/basis/bit-arrays/bit-arrays.factor @@ -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 ] [ - [let | out [ n log2 1+ ] 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 = [ + + ] [ + [ log2 1+ 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 ) From a1e521b54ee51f3a2e2a9329923e3d97b04551fb Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 18:42:21 -0600 Subject: [PATCH 07/10] working on images protocol --- extra/images/backend/backend.factor | 44 ++++++++++++++++----- extra/images/bitmap/bitmap.factor | 21 +++++----- extra/images/images.factor | 17 +++++++-- extra/images/tiff/tiff.factor | 24 ++++++------ extra/images/viewer/viewer.factor | 59 +++++------------------------ 5 files changed, 77 insertions(+), 88 deletions(-) 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. ; From 1d5f6901c1224a8f964c148a5615739c87193297 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 18:48:10 -0600 Subject: [PATCH 08/10] fix bitmap drawing --- extra/images/backend/backend.factor | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/extra/images/backend/backend.factor b/extra/images/backend/backend.factor index fb859f31a5..796e9a3a66 100644 --- a/extra/images/backend/backend.factor +++ b/extra/images/backend/backend.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel grouping fry sequences combinators ; +USING: accessors kernel grouping fry sequences combinators +images.bitmap math ; IN: images.backend SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ; @@ -37,8 +38,17 @@ GENERIC: >image ( object -- image ) ] } } 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 reverse concat + >>bitmap ; + : normalize-image ( image -- image ) - normalize-component-order ; + normalize-component-order + normalize-scan-line-order ; : new-image ( dim component-order bitmap class -- image ) new From 7d60fcc5989134f95a57299615e94be2fbdfabd7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 18:52:28 -0600 Subject: [PATCH 09/10] clean up some image code --- extra/images/backend/backend.factor | 7 +++---- extra/images/viewer/viewer.factor | 11 +++++++---- 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/extra/images/backend/backend.factor b/extra/images/backend/backend.factor index 796e9a3a66..2e626b73e6 100644 --- a/extra/images/backend/backend.factor +++ b/extra/images/backend/backend.factor @@ -5,7 +5,6 @@ images.bitmap math ; IN: images.backend SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ; -! RGBA TUPLE: image dim component-order bitmap ; @@ -42,9 +41,9 @@ 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 reverse concat - >>bitmap ; + dup dim>> '[ + _ first 4 * reverse concat + ] change-bitmap ; : normalize-image ( image -- image ) normalize-component-order diff --git a/extra/images/viewer/viewer.factor b/extra/images/viewer/viewer.factor index f99c34f509..92277dfdef 100644 --- a/extra/images/viewer/viewer.factor +++ b/extra/images/viewer/viewer.factor @@ -25,10 +25,13 @@ M: image-gadget draw-gadget* ( gadget -- ) : image-window ( path -- gadget ) [ dup ] [ open-window ] bi ; -GENERIC: image. ( image -- ) +GENERIC: image. ( object -- ) -M: string image. ( image -- ) gadget. ; +: default-image. ( path -- ) + gadget. ; -M: pathname image. ( image -- ) gadget. ; +M: string image. ( image -- ) default-image. ; -M: image image. ( image -- ) gadget. ; +M: pathname image. ( image -- ) default-image. ; + +M: image image. ( image -- ) default-image. ; From 94f6d28f34d7a3f0a31a9c3c35ba354d54e69704 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 19:34:02 -0600 Subject: [PATCH 10/10] fix a method --- extra/images/backend/backend.factor | 5 ----- extra/images/bitmap/bitmap.factor | 5 +++++ 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/images/backend/backend.factor b/extra/images/backend/backend.factor index 2e626b73e6..6d73a253ae 100644 --- a/extra/images/backend/backend.factor +++ b/extra/images/backend/backend.factor @@ -40,11 +40,6 @@ GENERIC: >image ( object -- image ) GENERIC: normalize-scan-line-order ( image -- image ) M: image normalize-scan-line-order ; -M: bitmap-image normalize-scan-line-order - dup dim>> '[ - _ first 4 * reverse concat - ] change-bitmap ; - : normalize-image ( image -- image ) normalize-component-order normalize-scan-line-order ; diff --git a/extra/images/bitmap/bitmap.factor b/extra/images/bitmap/bitmap.factor index 7b59827d02..46f90e33f8 100755 --- a/extra/images/bitmap/bitmap.factor +++ b/extra/images/bitmap/bitmap.factor @@ -112,6 +112,11 @@ M: bitmap >image ( bitmap -- bitmap-image ) M: bitmap-image load-image* ( path bitmap -- bitmap-image ) drop load-bitmap >image ; +M: bitmap-image normalize-scan-line-order + dup dim>> '[ + _ first 4 * reverse concat + ] change-bitmap ; + MACRO: (nbits>bitmap) ( bits -- ) [ -3 shift ] keep '[ bitmap new