! 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
: ?{ \ } [ >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 )
[ 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
reverse [ no-cond ] swap alist>quot ;
! case
-ERROR: no-case ;
+ERROR: no-case object ;
: case-find ( obj assoc -- obj' )
[
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 )
! 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 ;
+! RGBA
+
+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 )
+
+: 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 ( width height depth buffer class -- image )
+: 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
: 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" ;
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' )
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 ;
MACRO: (nbits>bitmap) ( bits -- )
[ -3 shift ] keep '[
swap >>height
swap >>width
swap array-copy [ >>buffer ] [ >>color-index ] bi
- _ >>bit-count bitmap>image
+ _ >>bit-count >image
] ;
: bgr>bitmap ( array height width -- bitmap )
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 ;
! 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 ;
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 ;
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 ;
! 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 ;
\ 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. ( image -- )
M: string image. ( image -- ) <image> <image-gadget> gadget. ;