--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test constructors calendar kernel accessors
+combinators.short-circuit ;
+IN: constructors.tests
+
+TUPLE: stock-spread stock spread timestamp ;
+
+CONSTRUCTOR: stock-spread ( stock spread -- stock-spread )
+ now >>timestamp ;
+
+SYMBOL: AAPL
+
+[ t ] [
+ AAPL 1234 <stock-spread>
+ {
+ [ stock>> AAPL eq? ]
+ [ spread>> 1234 = ]
+ [ timestamp>> timestamp? ]
+ } 1&&
+] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: slots kernel sequences fry accessors parser lexer words
+effects.parser macros ;
+IN: constructors
+
+! An experiment
+
+MACRO: set-slots ( slots -- quot )
+ <reversed> [ setter-word '[ swap _ execute ] ] map [ ] join ;
+
+: construct ( ... class slots -- instance )
+ [ new ] dip set-slots ; inline
+
+: define-constructor ( name class effect body -- )
+ [ [ in>> '[ _ _ construct ] ] dip compose ] [ drop ] 2bi
+ define-declared ;
+
+: CONSTRUCTOR:
+ scan-word [ name>> "<" ">" surround create-in ] keep
+ "(" expect ")" parse-effect
+ parse-definition
+ define-constructor ; parsing
\ No newline at end of file
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel grouping fry sequences combinators
+math ;
+IN: images.backend
+
+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 )
+
+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 ;
+: normalize-image ( image -- image )
+ normalize-component-order
+ normalize-scan-line-order ;
+
+: new-image ( dim component-order bitmap class -- image )
+ new
+ swap >>bitmap
+ swap >>component-order
+ swap >>dim ; inline
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: images.bitmap images.viewer io.encodings.binary
+io.files io.files.unique kernel tools.test ;
+IN: images.bitmap.tests
+
+: test-bitmap24 ( -- path )
+ "resource:extra/images/test-images/thiswayup24.bmp" ;
+
+: test-bitmap8 ( -- path )
+ "resource:extra/images/test-images/rgb8bit.bmp" ;
+
+: test-bitmap4 ( -- path )
+ "resource:extra/images/test-images/rgb4bit.bmp" ;
+
+: test-bitmap1 ( -- path )
+ "resource:extra/images/test-images/1bit.bmp" ;
+
+[ t ]
+[
+ test-bitmap24
+ [ binary file-contents ] [ load-bitmap ] bi
+
+ "test-bitmap24" unique-file
+ [ save-bitmap ] [ binary file-contents ] bi =
+] unit-test
--- /dev/null
+! Copyright (C) 2007, 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.c-types arrays byte-arrays columns
+combinators fry grouping io io.binary io.encodings.binary
+io.files kernel libc macros math math.bitwise math.functions
+namespaces opengl opengl.gl prettyprint sequences strings
+summary ui ui.gadgets.panes images.backend ;
+IN: images.bitmap
+
+TUPLE: bitmap-image < image ;
+
+! Currently can only handle 24/32bit bitmaps.
+! Handles row-reversed bitmaps (their height is negative)
+
+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
+buffer ;
+
+: array-copy ( bitmap array -- bitmap array' )
+ over size-image>> abs memory>byte-array ;
+
+: 8bit>buffer ( bitmap -- array )
+ [ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
+ [ color-index>> >array ] bi [ swap nth ] with map concat ;
+
+ERROR: bmp-not-supported n ;
+
+: raw-bitmap>buffer ( bitmap -- array )
+ dup bit-count>>
+ {
+ { 32 [ color-index>> ] }
+ { 24 [ color-index>> ] }
+ { 16 [ bmp-not-supported ] }
+ { 8 [ 8bit>buffer ] }
+ { 4 [ bmp-not-supported ] }
+ { 2 [ bmp-not-supported ] }
+ { 1 [ bmp-not-supported ] }
+ } case >byte-array ;
+
+ERROR: bitmap-magic ;
+
+M: bitmap-magic summary
+ drop "First two bytes of bitmap stream must be 'BM'" ;
+
+: read2 ( -- n ) 2 read le> ;
+: read4 ( -- n ) 4 read le> ;
+
+: parse-file-header ( bitmap -- bitmap )
+ 2 read >string dup "BM" = [ bitmap-magic ] unless >>magic
+ read4 >>size
+ read4 >>reserved
+ read4 >>offset ;
+
+: parse-bitmap-header ( bitmap -- bitmap )
+ read4 >>header-length
+ read4 >>width
+ read4 >>height
+ read2 >>planes
+ read2 >>bit-count
+ read4 >>compression
+ read4 >>size-image
+ read4 >>x-pels
+ read4 >>y-pels
+ read4 >>color-used
+ read4 >>color-important ;
+
+: rgb-quads-length ( bitmap -- n )
+ [ offset>> 14 - ] [ header-length>> ] bi - ;
+
+: color-index-length ( bitmap -- n )
+ {
+ [ width>> ]
+ [ planes>> * ]
+ [ bit-count>> * 31 + 32 /i 4 * ]
+ [ height>> abs * ]
+ } cleave ;
+
+: parse-bitmap ( bitmap -- bitmap )
+ dup rgb-quads-length read >>rgb-quads
+ dup color-index-length read >>color-index ;
+
+: load-bitmap-data ( path -- bitmap )
+ binary [
+ bitmap new
+ parse-file-header parse-bitmap-header parse-bitmap
+ ] with-file-reader ;
+
+: process-bitmap-data ( bitmap -- bitmap )
+ dup raw-bitmap>buffer >>buffer ;
+
+: 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 ;
+
+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 >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 '[
+ bitmap new
+ 2over * _ * >>size-image
+ swap >>height
+ swap >>width
+ swap array-copy [ >>buffer ] [ >>color-index ] bi
+ _ >>bit-count >image
+ ] ;
+
+: bgr>bitmap ( array height width -- bitmap )
+ 24 (nbits>bitmap) ;
+
+: bgra>bitmap ( array height width -- bitmap )
+ 32 (nbits>bitmap) ;
+
+: write2 ( n -- ) 2 >le write ;
+: write4 ( n -- ) 4 >le write ;
+
+: save-bitmap ( bitmap path -- )
+ binary [
+ B{ CHAR: B CHAR: M } write
+ [
+ buffer>> length 14 + 40 + write4
+ 0 write4
+ 54 write4
+ 40 write4
+ ] [
+ {
+ [ width>> write4 ]
+ [ height>> write4 ]
+ [ planes>> 1 or write2 ]
+ [ bit-count>> 24 or write2 ]
+ [ compression>> 0 or write4 ]
+ [ size-image>> write4 ]
+ [ x-pels>> 0 or write4 ]
+ [ y-pels>> 0 or write4 ]
+ [ color-used>> 0 or write4 ]
+ [ color-important>> 0 or write4 ]
+ [ rgb-quads>> write ]
+ [ color-index>> write ]
+ } cleave
+ ] bi
+ ] with-file-writer ;
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: constructors kernel splitting unicode.case combinators
+accessors images.bitmap images.tiff images.backend io.backend
+io.pathnames ;
+IN: images
+
+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 ;
--- /dev/null
+bitmap graphics
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test images.tiff ;
+IN: images.tiff.tests
+
+: tiff-test-path ( -- path )
+ "resource:extra/images/test-images/rgb.tiff" ;
+
+: tiff-test-path2 ( -- path )
+ "resource:extra/images/test-images/octagon.tiff" ;
--- /dev/null
+! 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 constructors sequences arrays math.order math.parser
+prettyprint classes io.binary assocs math math.bitwise byte-arrays
+grouping images.backend ;
+IN: images.tiff
+
+TUPLE: tiff-image < image ;
+
+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 bitmap ;
+CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ;
+
+TUPLE: ifd-entry tag type count offset/value ;
+CONSTRUCTOR: ifd-entry ( tag type count offset/value -- ifd-entry ) ;
+
+SINGLETONS: photometric-interpretation
+photometric-interpretation-white-is-zero
+photometric-interpretation-black-is-zero
+photometric-interpretation-rgb
+photometric-interpretation-palette-color ;
+ERROR: bad-photometric-interpretation n ;
+: lookup-photometric-interpretation ( n -- singleton )
+ {
+ { 0 [ photometric-interpretation-white-is-zero ] }
+ { 1 [ photometric-interpretation-black-is-zero ] }
+ { 2 [ photometric-interpretation-rgb ] }
+ { 3 [ photometric-interpretation-palette-color ] }
+ [ bad-photometric-interpretation ]
+ } case ;
+
+SINGLETONS: compression
+compression-none
+compression-CCITT-2
+compression-lzw
+compression-pack-bits ;
+ERROR: bad-compression n ;
+: lookup-compression ( n -- compression )
+ {
+ { 1 [ compression-none ] }
+ { 2 [ compression-CCITT-2 ] }
+ { 5 [ compression-lzw ] }
+ { 32773 [ compression-pack-bits ] }
+ [ bad-compression ]
+ } case ;
+
+SINGLETONS: resolution-unit
+resolution-unit-none
+resolution-unit-inch
+resolution-unit-centimeter ;
+ERROR: bad-resolution-unit n ;
+: lookup-resolution-unit ( n -- object )
+ {
+ { 1 [ resolution-unit-none ] }
+ { 2 [ resolution-unit-inch ] }
+ { 3 [ resolution-unit-centimeter ] }
+ [ bad-resolution-unit ]
+ } case ;
+
+SINGLETONS: predictor
+predictor-none
+predictor-horizontal-differencing ;
+ERROR: bad-predictor n ;
+: lookup-predictor ( n -- object )
+ {
+ { 1 [ predictor-none ] }
+ { 2 [ predictor-horizontal-differencing ] }
+ [ bad-predictor ]
+ } case ;
+
+SINGLETONS: planar-configuration
+planar-configuration-chunky
+planar-configuration-planar ;
+ERROR: bad-planar-configuration n ;
+: lookup-planar-configuration ( n -- object )
+ {
+ { 1 [ planar-configuration-chunky ] }
+ { 2 [ planar-configuration-planar ] }
+ [ bad-planar-configuration ]
+ } case ;
+
+SINGLETONS: sample-format
+sample-format-unsigned-integer
+sample-format-signed-integer
+sample-format-ieee-float
+sample-format-undefined-data ;
+ERROR: bad-sample-format n ;
+: lookup-sample-format ( sequence -- object )
+ [
+ {
+ { 1 [ sample-format-unsigned-integer ] }
+ { 2 [ sample-format-signed-integer ] }
+ { 3 [ sample-format-ieee-float ] }
+ { 4 [ sample-format-undefined-data ] }
+ [ bad-sample-format ]
+ } case
+ ] map ;
+
+SINGLETONS: extra-samples
+extra-samples-unspecified-alpha-data
+extra-samples-associated-alpha-data
+extra-samples-unassociated-alpha-data ;
+ERROR: bad-extra-samples n ;
+: lookup-extra-samples ( sequence -- object )
+ {
+ { 0 [ extra-samples-unspecified-alpha-data ] }
+ { 1 [ extra-samples-associated-alpha-data ] }
+ { 2 [ extra-samples-unassociated-alpha-data ] }
+ [ bad-extra-samples ]
+ } case ;
+
+SINGLETONS: image-length image-width x-resolution y-resolution
+rows-per-strip strip-offsets strip-byte-counts bits-per-sample
+samples-per-pixel new-subfile-type orientation
+unhandled-ifd-entry ;
+
+ERROR: bad-tiff-magic bytes ;
+: tiff-endianness ( byte-array -- ? )
+ {
+ { B{ CHAR: M CHAR: M } [ big-endian ] }
+ { B{ CHAR: I CHAR: I } [ little-endian ] }
+ [ bad-tiff-magic ]
+ } case ;
+
+: read-header ( tiff -- tiff )
+ 2 read tiff-endianness [ >>endianness ] keep
+ [
+ 2 read endian> >>the-answer
+ 4 read endian> >>ifd-offset
+ ] with-endianness ;
+
+: push-ifd ( tiff ifd -- tiff ) over ifds>> push ;
+
+: read-ifd ( -- ifd )
+ 2 read endian>
+ 2 read endian>
+ 4 read endian>
+ 4 read endian> <ifd-entry> ;
+
+: read-ifds ( tiff -- tiff )
+ dup ifd-offset>> seek-absolute seek-input
+ 2 read endian>
+ dup [ read-ifd ] replicate
+ 4 read endian>
+ [ <ifd> push-ifd ] [ 0 = [ read-ifds ] unless ] bi ;
+
+ERROR: no-tag class ;
+
+: ?at ( key assoc -- value/key ? )
+ dupd at* [ nip t ] [ drop f ] if ; inline
+
+: find-tag ( idf class -- tag )
+ swap processed-tags>> ?at [ no-tag ] unless ;
+
+: read-strips ( ifd -- ifd )
+ dup
+ [ strip-byte-counts find-tag ]
+ [ strip-offsets find-tag ] bi
+ 2dup [ integer? ] both? [
+ seek-absolute seek-input read 1array
+ ] [
+ [ seek-absolute seek-input read ] { } 2map-as
+ ] if >>strips ;
+
+ERROR: unknown-ifd-type n ;
+
+: bytes>bits ( n/byte-array -- n )
+ dup byte-array? [ byte-array>bignum ] when ;
+
+: value-length ( ifd-entry -- n )
+ [ count>> ] [ type>> ] bi {
+ { 1 [ ] }
+ { 2 [ ] }
+ { 3 [ 2 * ] }
+ { 4 [ 4 * ] }
+ { 5 [ 8 * ] }
+ { 6 [ ] }
+ { 7 [ ] }
+ { 8 [ 2 * ] }
+ { 9 [ 4 * ] }
+ { 10 [ 8 * ] }
+ { 11 [ 4 * ] }
+ { 12 [ 8 * ] }
+ [ unknown-ifd-type ]
+ } case ;
+
+ERROR: bad-small-ifd-type n ;
+
+: adjust-offset/value ( ifd-entry -- obj )
+ [ offset/value>> 4 >endian ] [ type>> ] bi
+ {
+ { 1 [ 1 head endian> ] }
+ { 3 [ 2 head endian> ] }
+ { 4 [ endian> ] }
+ { 6 [ 1 head endian> 8 >signed ] }
+ { 8 [ 2 head endian> 16 >signed ] }
+ { 9 [ endian> 32 >signed ] }
+ { 11 [ endian> bits>float ] }
+ [ bad-small-ifd-type ]
+ } case ;
+
+: offset-bytes>obj ( bytes type -- obj )
+ {
+ { 1 [ ] } ! blank
+ { 2 [ ] } ! read c strings here
+ { 3 [ 2 <sliced-groups> [ endian> ] map ] }
+ { 4 [ 4 <sliced-groups> [ endian> ] map ] }
+ { 5 [ 8 <sliced-groups> [ "II" unpack first2 / ] map ] }
+ { 6 [ [ 8 >signed ] map ] }
+ { 7 [ ] } ! blank
+ { 8 [ 2 <sliced-groups> [ endian> 16 >signed ] map ] }
+ { 9 [ 4 <sliced-groups> [ endian> 32 >signed ] map ] }
+ { 10 [ 8 group [ "ii" unpack first2 / ] map ] }
+ { 11 [ 4 group [ "f" unpack ] map ] }
+ { 12 [ 8 group [ "d" unpack ] map ] }
+ [ unknown-ifd-type ]
+ } case ;
+
+: ifd-entry-value ( ifd-entry -- n )
+ dup value-length 4 <= [
+ adjust-offset/value
+ ] [
+ [ offset/value>> seek-absolute seek-input ]
+ [ value-length read ]
+ [ type>> ] tri offset-bytes>obj
+ ] if ;
+
+: process-ifd-entry ( ifd-entry -- value class )
+ [ ifd-entry-value ] [ tag>> ] bi {
+ { 254 [ new-subfile-type ] }
+ { 256 [ image-width ] }
+ { 257 [ image-length ] }
+ { 258 [ bits-per-sample ] }
+ { 259 [ lookup-compression compression ] }
+ { 262 [ lookup-photometric-interpretation photometric-interpretation ] }
+ { 273 [ strip-offsets ] }
+ { 274 [ orientation ] }
+ { 277 [ samples-per-pixel ] }
+ { 278 [ rows-per-strip ] }
+ { 279 [ strip-byte-counts ] }
+ { 282 [ x-resolution ] }
+ { 283 [ y-resolution ] }
+ { 284 [ planar-configuration ] }
+ { 296 [ lookup-resolution-unit resolution-unit ] }
+ { 317 [ lookup-predictor predictor ] }
+ { 338 [ lookup-extra-samples extra-samples ] }
+ { 339 [ lookup-sample-format sample-format ] }
+ [ nip unhandled-ifd-entry ]
+ } case ;
+
+: process-ifd ( ifd -- ifd )
+ dup ifd-entries>>
+ [ process-ifd-entry swap ] H{ } map>assoc >>processed-tags ;
+
+: 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 ;
+
+M: ifd >image ( ifd -- image )
+ {
+ [ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
+ [ ifd-component-order ]
+ [ bitmap>> ]
+ } cleave tiff-image new-image ;
+
+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>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 >image ;
+++ /dev/null
-Slava Pestov
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test constructors calendar kernel accessors
-combinators.short-circuit ;
-IN: constructors.tests
-
-TUPLE: stock-spread stock spread timestamp ;
-
-CONSTRUCTOR: stock-spread ( stock spread -- stock-spread )
- now >>timestamp ;
-
-SYMBOL: AAPL
-
-[ t ] [
- AAPL 1234 <stock-spread>
- {
- [ stock>> AAPL eq? ]
- [ spread>> 1234 = ]
- [ timestamp>> timestamp? ]
- } 1&&
-] unit-test
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: slots kernel sequences fry accessors parser lexer words
-effects.parser macros ;
-IN: constructors
-
-! An experiment
-
-MACRO: set-slots ( slots -- quot )
- <reversed> [ setter-word '[ swap _ execute ] ] map [ ] join ;
-
-: construct ( ... class slots -- instance )
- [ new ] dip set-slots ; inline
-
-: define-constructor ( name class effect body -- )
- [ [ in>> '[ _ _ construct ] ] dip compose ] [ drop ] 2bi
- define-declared ;
-
-: CONSTRUCTOR:
- scan-word [ name>> "<" ">" surround create-in ] keep
- "(" expect ")" parse-effect
- parse-definition
- define-constructor ; parsing
\ No newline at end of file
+++ /dev/null
-Doug Coleman
\ No newline at end of file
+++ /dev/null
-Doug Coleman
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel grouping fry sequences combinators
-math ;
-IN: images.backend
-
-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 )
-
-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 ;
-: normalize-image ( image -- image )
- normalize-component-order
- normalize-scan-line-order ;
-
-: new-image ( dim component-order bitmap class -- image )
- new
- swap >>bitmap
- swap >>component-order
- swap >>dim ; inline
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: images.bitmap images.viewer io.encodings.binary
-io.files io.files.unique kernel tools.test ;
-IN: images.bitmap.tests
-
-: test-bitmap24 ( -- path )
- "resource:extra/images/test-images/thiswayup24.bmp" ;
-
-: test-bitmap8 ( -- path )
- "resource:extra/images/test-images/rgb8bit.bmp" ;
-
-: test-bitmap4 ( -- path )
- "resource:extra/images/test-images/rgb4bit.bmp" ;
-
-: test-bitmap1 ( -- path )
- "resource:extra/images/test-images/1bit.bmp" ;
-
-[ t ]
-[
- test-bitmap24
- [ binary file-contents ] [ load-bitmap ] bi
-
- "test-bitmap24" unique-file
- [ save-bitmap ] [ binary file-contents ] bi =
-] unit-test
+++ /dev/null
-! Copyright (C) 2007, 2009 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types arrays byte-arrays columns
-combinators fry grouping io io.binary io.encodings.binary
-io.files kernel libc macros math math.bitwise math.functions
-namespaces opengl opengl.gl prettyprint sequences strings
-summary ui ui.gadgets.panes images.backend ;
-IN: images.bitmap
-
-TUPLE: bitmap-image < image ;
-
-! Currently can only handle 24/32bit bitmaps.
-! Handles row-reversed bitmaps (their height is negative)
-
-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
-buffer ;
-
-: array-copy ( bitmap array -- bitmap array' )
- over size-image>> abs memory>byte-array ;
-
-: 8bit>buffer ( bitmap -- array )
- [ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
- [ color-index>> >array ] bi [ swap nth ] with map concat ;
-
-ERROR: bmp-not-supported n ;
-
-: raw-bitmap>buffer ( bitmap -- array )
- dup bit-count>>
- {
- { 32 [ color-index>> ] }
- { 24 [ color-index>> ] }
- { 16 [ bmp-not-supported ] }
- { 8 [ 8bit>buffer ] }
- { 4 [ bmp-not-supported ] }
- { 2 [ bmp-not-supported ] }
- { 1 [ bmp-not-supported ] }
- } case >byte-array ;
-
-ERROR: bitmap-magic ;
-
-M: bitmap-magic summary
- drop "First two bytes of bitmap stream must be 'BM'" ;
-
-: read2 ( -- n ) 2 read le> ;
-: read4 ( -- n ) 4 read le> ;
-
-: parse-file-header ( bitmap -- bitmap )
- 2 read >string dup "BM" = [ bitmap-magic ] unless >>magic
- read4 >>size
- read4 >>reserved
- read4 >>offset ;
-
-: parse-bitmap-header ( bitmap -- bitmap )
- read4 >>header-length
- read4 >>width
- read4 >>height
- read2 >>planes
- read2 >>bit-count
- read4 >>compression
- read4 >>size-image
- read4 >>x-pels
- read4 >>y-pels
- read4 >>color-used
- read4 >>color-important ;
-
-: rgb-quads-length ( bitmap -- n )
- [ offset>> 14 - ] [ header-length>> ] bi - ;
-
-: color-index-length ( bitmap -- n )
- {
- [ width>> ]
- [ planes>> * ]
- [ bit-count>> * 31 + 32 /i 4 * ]
- [ height>> abs * ]
- } cleave ;
-
-: parse-bitmap ( bitmap -- bitmap )
- dup rgb-quads-length read >>rgb-quads
- dup color-index-length read >>color-index ;
-
-: load-bitmap-data ( path -- bitmap )
- binary [
- bitmap new
- parse-file-header parse-bitmap-header parse-bitmap
- ] with-file-reader ;
-
-: process-bitmap-data ( bitmap -- bitmap )
- dup raw-bitmap>buffer >>buffer ;
-
-: 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 ;
-
-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 >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 '[
- bitmap new
- 2over * _ * >>size-image
- swap >>height
- swap >>width
- swap array-copy [ >>buffer ] [ >>color-index ] bi
- _ >>bit-count >image
- ] ;
-
-: bgr>bitmap ( array height width -- bitmap )
- 24 (nbits>bitmap) ;
-
-: bgra>bitmap ( array height width -- bitmap )
- 32 (nbits>bitmap) ;
-
-: write2 ( n -- ) 2 >le write ;
-: write4 ( n -- ) 4 >le write ;
-
-: save-bitmap ( bitmap path -- )
- binary [
- B{ CHAR: B CHAR: M } write
- [
- buffer>> length 14 + 40 + write4
- 0 write4
- 54 write4
- 40 write4
- ] [
- {
- [ width>> write4 ]
- [ height>> write4 ]
- [ planes>> 1 or write2 ]
- [ bit-count>> 24 or write2 ]
- [ compression>> 0 or write4 ]
- [ size-image>> write4 ]
- [ x-pels>> 0 or write4 ]
- [ y-pels>> 0 or write4 ]
- [ color-used>> 0 or write4 ]
- [ color-important>> 0 or write4 ]
- [ rgb-quads>> write ]
- [ color-index>> write ]
- } cleave
- ] bi
- ] with-file-writer ;
+++ /dev/null
-! Copyright (C) 2009 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: constructors kernel splitting unicode.case combinators
-accessors images.bitmap images.tiff images.backend io.backend
-io.pathnames ;
-IN: images
-
-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 ;
+++ /dev/null
-bitmap graphics
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! Copyright (C) 2009 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test images.tiff ;
-IN: images.tiff.tests
-
-: tiff-test-path ( -- path )
- "resource:extra/images/test-images/rgb.tiff" ;
-
-: tiff-test-path2 ( -- path )
- "resource:extra/images/test-images/octagon.tiff" ;
+++ /dev/null
-! 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 constructors sequences arrays math.order math.parser
-prettyprint classes io.binary assocs math math.bitwise byte-arrays
-grouping images.backend ;
-IN: images.tiff
-
-TUPLE: tiff-image < image ;
-
-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 bitmap ;
-CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ;
-
-TUPLE: ifd-entry tag type count offset/value ;
-CONSTRUCTOR: ifd-entry ( tag type count offset/value -- ifd-entry ) ;
-
-SINGLETONS: photometric-interpretation
-photometric-interpretation-white-is-zero
-photometric-interpretation-black-is-zero
-photometric-interpretation-rgb
-photometric-interpretation-palette-color ;
-ERROR: bad-photometric-interpretation n ;
-: lookup-photometric-interpretation ( n -- singleton )
- {
- { 0 [ photometric-interpretation-white-is-zero ] }
- { 1 [ photometric-interpretation-black-is-zero ] }
- { 2 [ photometric-interpretation-rgb ] }
- { 3 [ photometric-interpretation-palette-color ] }
- [ bad-photometric-interpretation ]
- } case ;
-
-SINGLETONS: compression
-compression-none
-compression-CCITT-2
-compression-lzw
-compression-pack-bits ;
-ERROR: bad-compression n ;
-: lookup-compression ( n -- compression )
- {
- { 1 [ compression-none ] }
- { 2 [ compression-CCITT-2 ] }
- { 5 [ compression-lzw ] }
- { 32773 [ compression-pack-bits ] }
- [ bad-compression ]
- } case ;
-
-SINGLETONS: resolution-unit
-resolution-unit-none
-resolution-unit-inch
-resolution-unit-centimeter ;
-ERROR: bad-resolution-unit n ;
-: lookup-resolution-unit ( n -- object )
- {
- { 1 [ resolution-unit-none ] }
- { 2 [ resolution-unit-inch ] }
- { 3 [ resolution-unit-centimeter ] }
- [ bad-resolution-unit ]
- } case ;
-
-SINGLETONS: predictor
-predictor-none
-predictor-horizontal-differencing ;
-ERROR: bad-predictor n ;
-: lookup-predictor ( n -- object )
- {
- { 1 [ predictor-none ] }
- { 2 [ predictor-horizontal-differencing ] }
- [ bad-predictor ]
- } case ;
-
-SINGLETONS: planar-configuration
-planar-configuration-chunky
-planar-configuration-planar ;
-ERROR: bad-planar-configuration n ;
-: lookup-planar-configuration ( n -- object )
- {
- { 1 [ planar-configuration-chunky ] }
- { 2 [ planar-configuration-planar ] }
- [ bad-planar-configuration ]
- } case ;
-
-SINGLETONS: sample-format
-sample-format-unsigned-integer
-sample-format-signed-integer
-sample-format-ieee-float
-sample-format-undefined-data ;
-ERROR: bad-sample-format n ;
-: lookup-sample-format ( sequence -- object )
- [
- {
- { 1 [ sample-format-unsigned-integer ] }
- { 2 [ sample-format-signed-integer ] }
- { 3 [ sample-format-ieee-float ] }
- { 4 [ sample-format-undefined-data ] }
- [ bad-sample-format ]
- } case
- ] map ;
-
-SINGLETONS: extra-samples
-extra-samples-unspecified-alpha-data
-extra-samples-associated-alpha-data
-extra-samples-unassociated-alpha-data ;
-ERROR: bad-extra-samples n ;
-: lookup-extra-samples ( sequence -- object )
- {
- { 0 [ extra-samples-unspecified-alpha-data ] }
- { 1 [ extra-samples-associated-alpha-data ] }
- { 2 [ extra-samples-unassociated-alpha-data ] }
- [ bad-extra-samples ]
- } case ;
-
-SINGLETONS: image-length image-width x-resolution y-resolution
-rows-per-strip strip-offsets strip-byte-counts bits-per-sample
-samples-per-pixel new-subfile-type orientation
-unhandled-ifd-entry ;
-
-ERROR: bad-tiff-magic bytes ;
-: tiff-endianness ( byte-array -- ? )
- {
- { B{ CHAR: M CHAR: M } [ big-endian ] }
- { B{ CHAR: I CHAR: I } [ little-endian ] }
- [ bad-tiff-magic ]
- } case ;
-
-: read-header ( tiff -- tiff )
- 2 read tiff-endianness [ >>endianness ] keep
- [
- 2 read endian> >>the-answer
- 4 read endian> >>ifd-offset
- ] with-endianness ;
-
-: push-ifd ( tiff ifd -- tiff ) over ifds>> push ;
-
-: read-ifd ( -- ifd )
- 2 read endian>
- 2 read endian>
- 4 read endian>
- 4 read endian> <ifd-entry> ;
-
-: read-ifds ( tiff -- tiff )
- dup ifd-offset>> seek-absolute seek-input
- 2 read endian>
- dup [ read-ifd ] replicate
- 4 read endian>
- [ <ifd> push-ifd ] [ 0 = [ read-ifds ] unless ] bi ;
-
-ERROR: no-tag class ;
-
-: ?at ( key assoc -- value/key ? )
- dupd at* [ nip t ] [ drop f ] if ; inline
-
-: find-tag ( idf class -- tag )
- swap processed-tags>> ?at [ no-tag ] unless ;
-
-: read-strips ( ifd -- ifd )
- dup
- [ strip-byte-counts find-tag ]
- [ strip-offsets find-tag ] bi
- 2dup [ integer? ] both? [
- seek-absolute seek-input read 1array
- ] [
- [ seek-absolute seek-input read ] { } 2map-as
- ] if >>strips ;
-
-ERROR: unknown-ifd-type n ;
-
-: bytes>bits ( n/byte-array -- n )
- dup byte-array? [ byte-array>bignum ] when ;
-
-: value-length ( ifd-entry -- n )
- [ count>> ] [ type>> ] bi {
- { 1 [ ] }
- { 2 [ ] }
- { 3 [ 2 * ] }
- { 4 [ 4 * ] }
- { 5 [ 8 * ] }
- { 6 [ ] }
- { 7 [ ] }
- { 8 [ 2 * ] }
- { 9 [ 4 * ] }
- { 10 [ 8 * ] }
- { 11 [ 4 * ] }
- { 12 [ 8 * ] }
- [ unknown-ifd-type ]
- } case ;
-
-ERROR: bad-small-ifd-type n ;
-
-: adjust-offset/value ( ifd-entry -- obj )
- [ offset/value>> 4 >endian ] [ type>> ] bi
- {
- { 1 [ 1 head endian> ] }
- { 3 [ 2 head endian> ] }
- { 4 [ endian> ] }
- { 6 [ 1 head endian> 8 >signed ] }
- { 8 [ 2 head endian> 16 >signed ] }
- { 9 [ endian> 32 >signed ] }
- { 11 [ endian> bits>float ] }
- [ bad-small-ifd-type ]
- } case ;
-
-: offset-bytes>obj ( bytes type -- obj )
- {
- { 1 [ ] } ! blank
- { 2 [ ] } ! read c strings here
- { 3 [ 2 <sliced-groups> [ endian> ] map ] }
- { 4 [ 4 <sliced-groups> [ endian> ] map ] }
- { 5 [ 8 <sliced-groups> [ "II" unpack first2 / ] map ] }
- { 6 [ [ 8 >signed ] map ] }
- { 7 [ ] } ! blank
- { 8 [ 2 <sliced-groups> [ endian> 16 >signed ] map ] }
- { 9 [ 4 <sliced-groups> [ endian> 32 >signed ] map ] }
- { 10 [ 8 group [ "ii" unpack first2 / ] map ] }
- { 11 [ 4 group [ "f" unpack ] map ] }
- { 12 [ 8 group [ "d" unpack ] map ] }
- [ unknown-ifd-type ]
- } case ;
-
-: ifd-entry-value ( ifd-entry -- n )
- dup value-length 4 <= [
- adjust-offset/value
- ] [
- [ offset/value>> seek-absolute seek-input ]
- [ value-length read ]
- [ type>> ] tri offset-bytes>obj
- ] if ;
-
-: process-ifd-entry ( ifd-entry -- value class )
- [ ifd-entry-value ] [ tag>> ] bi {
- { 254 [ new-subfile-type ] }
- { 256 [ image-width ] }
- { 257 [ image-length ] }
- { 258 [ bits-per-sample ] }
- { 259 [ lookup-compression compression ] }
- { 262 [ lookup-photometric-interpretation photometric-interpretation ] }
- { 273 [ strip-offsets ] }
- { 274 [ orientation ] }
- { 277 [ samples-per-pixel ] }
- { 278 [ rows-per-strip ] }
- { 279 [ strip-byte-counts ] }
- { 282 [ x-resolution ] }
- { 283 [ y-resolution ] }
- { 284 [ planar-configuration ] }
- { 296 [ lookup-resolution-unit resolution-unit ] }
- { 317 [ lookup-predictor predictor ] }
- { 338 [ lookup-extra-samples extra-samples ] }
- { 339 [ lookup-sample-format sample-format ] }
- [ nip unhandled-ifd-entry ]
- } case ;
-
-: process-ifd ( ifd -- ifd )
- dup ifd-entries>>
- [ process-ifd-entry swap ] H{ } map>assoc >>processed-tags ;
-
-: 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 ;
-
-M: ifd >image ( ifd -- image )
- {
- [ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
- [ ifd-component-order ]
- [ bitmap>> ]
- } cleave tiff-image new-image ;
-
-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>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 >image ;
projects / factor.git / commitdiff