+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: images.bitmap images.testing kernel ;
-IN: images.bitmap.tests
-
-! "vocab:images/testing/bmp/1bit.bmp" decode-test
-! "vocab:images/testing/bmp/rgb_4bit.bmp" decode-test
-
-"vocab:images/testing/bmp/rgb_8bit.bmp"
-[ decode-test ] [ bmp-image encode-test ] bi
-
-"vocab:images/testing/bmp/42red_24bit.bmp"
-[ decode-test ] [ bmp-image encode-test ] bi
+++ /dev/null
-! Copyright (C) 2007, 2009 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types arrays byte-arrays combinators
-compression.run-length fry grouping images images.loader
-images.normalization io io.binary io.encodings.8-bit.latin1
-io.encodings.string kernel math math.bitwise sequences
-specialized-arrays summary io.streams.throwing ;
-QUALIFIED-WITH: bitstreams b
-SPECIALIZED-ARRAYS: uint ushort ;
-IN: images.bitmap
-
-! http://www.fileformat.info/format/bmp/egff.htm
-! http://www.digicamsoft.com/bmp/bmp.html
-
-SINGLETON: bmp-image
-"bmp" bmp-image register-image-class
-
-: write2 ( n -- ) 2 >le write ;
-: write4 ( n -- ) 4 >le write ;
-
-ERROR: unknown-component-order bitmap ;
-ERROR: unknown-bitmap-header n ;
-
-: read2 ( -- n ) 2 read le> ;
-: read4 ( -- n ) 4 read le> ;
-
-TUPLE: loading-bitmap
- file-header header
- color-palette color-index bitfields ;
-
-TUPLE: file-header
- { magic initial: "BM" }
- { size }
- { reserved1 initial: 0 }
- { reserved2 initial: 0 }
- { offset }
- { header-length } ;
-
-TUPLE: v3-header
- { width initial: 0 }
- { height initial: 0 }
- { planes initial: 0 }
- { bit-count initial: 0 }
- { compression initial: 0 }
- { image-size initial: 0 }
- { x-resolution initial: 0 }
- { y-resolution initial: 0 }
- { colors-used initial: 0 }
- { colors-important initial: 0 } ;
-
-TUPLE: v4-header < v3-header
- { red-mask initial: 0 }
- { green-mask initial: 0 }
- { blue-mask initial: 0 }
- { alpha-mask initial: 0 }
- { cs-type initial: 0 }
- { end-points initial: 0 }
- { gamma-red initial: 0 }
- { gamma-green initial: 0 }
- { gamma-blue initial: 0 } ;
-
-TUPLE: v5-header < v4-header
- { intent initial: 0 }
- { profile-data initial: 0 }
- { profile-size initial: 0 }
- { reserved3 initial: 0 } ;
-
-TUPLE: os2v1-header
- { width initial: 0 }
- { height initial: 0 }
- { planes initial: 0 }
- { bit-count initial: 0 } ;
-
-TUPLE: os2v2-header < os2v1-header
- { compression initial: 0 }
- { image-size initial: 0 }
- { x-resolution initial: 0 }
- { y-resolution initial: 0 }
- { colors-used initial: 0 }
- { colors-important initial: 0 }
- { units initial: 0 }
- { reserved initial: 0 }
- { recording initial: 0 }
- { rendering initial: 0 }
- { size1 initial: 0 }
- { size2 initial: 0 }
- { color-encoding initial: 0 }
- { identifier initial: 0 } ;
-
-UNION: v-header v3-header v4-header v5-header ;
-UNION: os2-header os2v1-header os2v2-header ;
-
-: parse-file-header ( -- file-header )
- \ file-header new
- 2 read latin1 decode >>magic
- read4 >>size
- read2 >>reserved1
- read2 >>reserved2
- read4 >>offset
- read4 >>header-length ;
-
-: read-v3-header-data ( header -- header )
- read4 >>width
- read4 32 >signed >>height
- read2 >>planes
- read2 >>bit-count
- read4 >>compression
- read4 >>image-size
- read4 >>x-resolution
- read4 >>y-resolution
- read4 >>colors-used
- read4 >>colors-important ;
-
-: read-v3-header ( -- header )
- \ v3-header new
- read-v3-header-data ;
-
-: read-v4-header-data ( header -- header )
- read4 >>red-mask
- read4 >>green-mask
- read4 >>blue-mask
- read4 >>alpha-mask
- read4 >>cs-type
- read4 read4 read4 3array >>end-points
- read4 >>gamma-red
- read4 >>gamma-green
- read4 >>gamma-blue ;
-
-: read-v4-header ( -- v4-header )
- \ v4-header new
- read-v3-header-data
- read-v4-header-data ;
-
-: read-v5-header-data ( v5-header -- v5-header )
- read4 >>intent
- read4 >>profile-data
- read4 >>profile-size
- read4 >>reserved3 ;
-
-: read-v5-header ( -- loading-bitmap )
- \ v5-header new
- read-v3-header-data
- read-v4-header-data
- read-v5-header-data ;
-
-: read-os2v1-header ( -- os2v1-header )
- \ os2v1-header new
- read2 >>width
- read2 16 >signed >>height
- read2 >>planes
- read2 >>bit-count ;
-
-: read-os2v2-header-data ( os2v2-header -- os2v2-header )
- read4 >>width
- read4 32 >signed >>height
- read2 >>planes
- read2 >>bit-count
- read4 >>compression
- read4 >>image-size
- read4 >>x-resolution
- read4 >>y-resolution
- read4 >>colors-used
- read4 >>colors-important
- read2 >>units
- read2 >>reserved
- read2 >>recording
- read2 >>rendering
- read4 >>size1
- read4 >>size2
- read4 >>color-encoding
- read4 >>identifier ;
-
-: read-os2v2-header ( -- os2v2-header )
- \ os2v2-header new
- read-os2v2-header-data ;
-
-: parse-header ( n -- header )
- {
- { 12 [ read-os2v1-header ] }
- { 64 [ read-os2v2-header ] }
- { 40 [ read-v3-header ] }
- { 108 [ read-v4-header ] }
- { 124 [ read-v5-header ] }
- [ unknown-bitmap-header ]
- } case ;
-
-: color-index-length ( header -- n )
- {
- [ width>> ]
- [ planes>> * ]
- [ bit-count>> * 31 + 32 /i 4 * ]
- [ height>> abs * ]
- } cleave ;
-
-: color-palette-length ( loading-bitmap -- n )
- file-header>>
- [ offset>> 14 - ] [ header-length>> ] bi - ;
-
-: parse-color-palette ( loading-bitmap -- loading-bitmap )
- dup color-palette-length read >>color-palette ;
-
-GENERIC: parse-color-data* ( loading-bitmap header -- loading-bitmap )
-
-: parse-color-data ( loading-bitmap -- loading-bitmap )
- dup header>> parse-color-data* ;
-
-M: os2v1-header parse-color-data* ( loading-bitmap header -- loading-bitmap )
- color-index-length read >>color-index ;
-
-M: object parse-color-data* ( loading-bitmap header -- loading-bitmap )
- dup image-size>> [ 0 ] unless* dup 0 >
- [ nip ] [ drop color-index-length ] if read >>color-index ;
-
-: alpha-used? ( loading-bitmap -- ? )
- color-index>> 4 <sliced-groups> [ fourth 0 = ] all? not ;
-
-GENERIC: bitmap>component-order* ( loading-bitmap header -- object )
-
-: bitmap>component-order ( loading-bitmap -- object )
- dup header>> bitmap>component-order* ;
-
-: simple-bitmap>component-order ( loading-bitamp -- object )
- header>> bit-count>> {
- { 32 [ BGRX ] }
- { 24 [ BGR ] }
- { 16 [ BGR ] }
- { 8 [ BGR ] }
- { 4 [ BGR ] }
- { 1 [ BGR ] }
- [ unknown-component-order ]
- } case ;
-
-: advanced-bitmap>component-order ( loading-bitmap -- object )
- [ ] [ header>> bit-count>> ] [ alpha-used? ] tri 2array {
- { { 32 t } [ drop BGRA ] }
- { { 32 f } [ drop BGRX ] }
- [ drop simple-bitmap>component-order ]
- } case ;
-
-: color-lookup3 ( loading-bitmap -- seq )
- [ color-index>> >array ]
- [ color-palette>> 3 <sliced-groups> ] bi
- '[ _ nth ] map concat ;
-
-: color-lookup4 ( loading-bitmap -- seq )
- [ color-index>> >array ]
- [ color-palette>> 4 <sliced-groups> [ 3 head-slice ] map ] bi
- '[ _ nth ] map concat ;
-
-! os2v1 is 3bytes each, all others are 3 + 1 unused
-: color-lookup ( loading-bitmap -- seq )
- dup file-header>> header-length>> {
- { 12 [ color-lookup3 ] }
- { 64 [ color-lookup4 ] }
- { 40 [ color-lookup4 ] }
- { 108 [ color-lookup4 ] }
- { 124 [ color-lookup4 ] }
- } case ;
-
-M: os2v1-header bitmap>component-order* drop simple-bitmap>component-order ;
-M: os2v2-header bitmap>component-order* drop simple-bitmap>component-order ;
-M: v3-header bitmap>component-order* drop simple-bitmap>component-order ;
-M: v4-header bitmap>component-order* drop advanced-bitmap>component-order ;
-M: v5-header bitmap>component-order* drop advanced-bitmap>component-order ;
-
-: uncompress-bitfield ( seq masks -- bytes' )
- '[
- _ [
- [ bitand ] [ bit-count ] [ log2 ] tri - shift
- ] with map
- ] { } map-as B{ } concat-as ;
-
-ERROR: bmp-not-supported n ;
-
-: bitmap>bytes ( loading-bitmap -- byte-array )
- dup header>> bit-count>>
- {
- { 32 [ color-index>> ] }
- { 24 [ color-index>> ] }
- { 16 [
- [
- ! ushort-array-cast
- 2 group [ le> ] map
- ! 5 6 5
- ! { HEX: f800 HEX: 7e0 HEX: 1f } uncompress-bitfield
- ! 5 5 5
- { HEX: 7c00 HEX: 3e0 HEX: 1f } uncompress-bitfield
- ] change-color-index
- color-index>>
- ] }
- { 8 [ color-lookup ] }
- { 4 [ [ 4 b:byte-array-n>seq ] change-color-index color-lookup ] }
- { 1 [ [ 1 b:byte-array-n>seq ] change-color-index color-lookup ] }
- [ bmp-not-supported ]
- } case >byte-array ;
-
-: set-bitfield-widths ( loading-bitmap -- loading-bitmap' )
- dup header>> bit-count>> {
- { 16 [ dup color-palette>> 4 group [ le> ] map ] }
- { 32 [ { HEX: ff0000 HEX: ff00 HEX: ff } ] }
- } case reverse >>bitfields ;
-
-ERROR: unsupported-bitfield-widths n ;
-
-M: unsupported-bitfield-widths summary
- drop "Bitmaps only support bitfield compression in 16/32bit images" ;
-
-: uncompress-bitfield-widths ( loading-bitmap -- loading-bitmap' )
- set-bitfield-widths
- dup header>> bit-count>> {
- { 16 [
- dup bitfields>> '[
- ushort-array-cast _ uncompress-bitfield
- ] change-color-index
- ] }
- { 32 [ ] }
- [ unsupported-bitfield-widths ]
- } case ;
-
-ERROR: unsupported-bitmap-compression compression ;
-
-GENERIC: uncompress-bitmap* ( loading-bitmap header -- loading-bitmap )
-
-: uncompress-bitmap ( loading-bitmap -- loading-bitmap )
- dup header>> uncompress-bitmap* ;
-
-M: os2-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' )
- drop ;
-
-: do-run-length-uncompress ( loading-bitmap word -- loading-bitmap )
- dupd '[
- _ header>> [ width>> ] [ height>> ] bi
- _ execute
- ] change-color-index ; inline
-
-M: v-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' )
- compression>> {
- { f [ ] }
- { 0 [ ] }
- { 1 [ \ run-length-uncompress-bitmap8 do-run-length-uncompress ] }
- { 2 [ \ run-length-uncompress-bitmap4 do-run-length-uncompress ] }
- { 3 [ uncompress-bitfield-widths ] }
- { 4 [ "jpeg" unsupported-bitmap-compression ] }
- { 5 [ "png" unsupported-bitmap-compression ] }
- } case ;
-
-ERROR: unsupported-bitmap-file magic ;
-
-: load-bitmap ( stream -- loading-bitmap )
- [
- [
- \ loading-bitmap new
- parse-file-header [ >>file-header ] [ ] bi magic>> {
- { "BM" [
- dup file-header>> header-length>> parse-header >>header
- parse-color-palette
- parse-color-data
- ] }
- ! { "BA" [ parse-os2-bitmap-array ] }
- ! { "CI" [ parse-os2-color-icon ] }
- ! { "CP" [ parse-os2-color-pointer ] }
- ! { "IC" [ parse-os2-icon ] }
- ! { "PT" [ parse-os2-pointer ] }
- [ unsupported-bitmap-file ]
- } case
- ] throw-on-eof
- ] with-input-stream ;
-
-: loading-bitmap>bytes ( loading-bitmap -- byte-array )
- uncompress-bitmap bitmap>bytes ;
-
-M: bmp-image stream>image ( stream bmp-image -- bitmap )
- drop load-bitmap
- [ image new ] dip
- {
- [ loading-bitmap>bytes >>bitmap ]
- [ header>> [ width>> ] [ height>> abs ] bi 2array >>dim ]
- [ header>> height>> 0 < not >>upside-down? ]
- [ bitmap>component-order >>component-order ubyte-components >>component-type ]
- } cleave ;
-
-: output-width-and-height ( image -- )
- [ dim>> first write4 ]
- [
- [ dim>> second ] [ upside-down?>> ] bi
- [ neg ] unless write4
- ] bi ;
-
-: output-bmp ( image -- )
- B{ CHAR: B CHAR: M } write
- [
- bitmap>> length 14 + 40 + write4
- 0 write4
- 54 write4
- 40 write4
- ] [
- {
- [ output-width-and-height ]
-
- ! planes
- [ drop 1 write2 ]
-
- ! bit-count
- [ drop 24 write2 ]
-
- ! compression
- [ drop 0 write4 ]
-
- ! image-size
- [ bitmap>> length write4 ]
-
- ! x-pels
- [ drop 0 write4 ]
-
- ! y-pels
- [ drop 0 write4 ]
-
- ! color-used
- [ drop 0 write4 ]
-
- ! color-important
- [ drop 0 write4 ]
-
- ! color-palette
- [ bitmap>> write ]
- } cleave
- ] bi ;
-
-M: bmp-image image>stream
- drop BGR reorder-components output-bmp ;
-
+++ /dev/null
-Windows BMP image loader
+++ /dev/null
-! Copyright (C) 2009 Marc Fauconneau.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays byte-arrays combinators
-compression.huffman fry grouping images images.loader
-images.processing io io.binary io.encodings.binary
-io.streams.byte-array io.streams.limited io.streams.throwing
-kernel locals math math.bitwise math.blas.matrices
-math.blas.vectors math.constants math.functions math.matrices
-math.order math.vectors memoize namespaces sequences
-sequences.deep ;
-QUALIFIED-WITH: bitstreams bs
-IN: images.jpeg
-
-SINGLETON: jpeg-image
-
-TUPLE: loading-jpeg < image
- { headers }
- { bitstream }
- { color-info initial: { f f f f } }
- { quant-tables initial: { f f } }
- { huff-tables initial: { f f f f } }
- { components } ;
-
-"jpg" jpeg-image register-image-class
-"jpeg" jpeg-image register-image-class
-
-<PRIVATE
-
-: <loading-jpeg> ( headers bitstream -- image )
- loading-jpeg new swap >>bitstream swap >>headers ;
-
-SINGLETONS: SOF DHT DAC RST SOI EOI SOS DQT DNL DRI DHP EXP
-APP JPG COM TEM RES ;
-
-! ISO/IEC 10918-1 Table B.1
-:: >marker ( byte -- marker )
- byte
- {
- { [ dup HEX: CC = ] [ { DAC } ] }
- { [ dup HEX: C4 = ] [ { DHT } ] }
- { [ dup HEX: C9 = ] [ { JPG } ] }
- { [ dup -4 shift HEX: C = ] [ SOF byte 4 bits 2array ] }
-
- { [ dup HEX: D8 = ] [ { SOI } ] }
- { [ dup HEX: D9 = ] [ { EOI } ] }
- { [ dup HEX: DA = ] [ { SOS } ] }
- { [ dup HEX: DB = ] [ { DQT } ] }
- { [ dup HEX: DC = ] [ { DNL } ] }
- { [ dup HEX: DD = ] [ { DRI } ] }
- { [ dup HEX: DE = ] [ { DHP } ] }
- { [ dup HEX: DF = ] [ { EXP } ] }
- { [ dup -4 shift HEX: D = ] [ RST byte 4 bits 2array ] }
-
- { [ dup -4 shift HEX: E = ] [ APP byte 4 bits 2array ] }
- { [ dup HEX: FE = ] [ { COM } ] }
- { [ dup -4 shift HEX: F = ] [ JPG byte 4 bits 2array ] }
-
- { [ dup HEX: 01 = ] [ { TEM } ] }
- [ { RES } ]
- }
- cond nip ;
-
-TUPLE: jpeg-chunk length type data ;
-
-: <jpeg-chunk> ( type length data -- jpeg-chunk )
- jpeg-chunk new
- swap >>data
- swap >>length
- swap >>type ;
-
-TUPLE: jpeg-color-info
- h v quant-table dc-huff-table ac-huff-table { diff initial: 0 } id ;
-
-: <jpeg-color-info> ( h v quant-table -- jpeg-color-info )
- jpeg-color-info new
- swap >>quant-table
- swap >>v
- swap >>h ;
-
-: jpeg> ( -- jpeg-image ) jpeg-image get ;
-
-: apply-diff ( dc color -- dc' )
- [ diff>> + dup ] [ diff<< ] bi ;
-
-: fetch-tables ( component -- )
- [ [ jpeg> quant-tables>> nth ] change-quant-table drop ]
- [ [ jpeg> huff-tables>> nth ] change-dc-huff-table drop ]
- [ [ 2 + jpeg> huff-tables>> nth ] change-ac-huff-table drop ] tri ;
-
-: read4/4 ( -- a b ) read1 16 /mod ;
-
-! headers
-
-: decode-frame ( header -- )
- data>>
- binary
- [
- read1 8 assert=
- 2 read be>
- 2 read be>
- swap 2array jpeg> dim<<
- read1
- [
- read1 read4/4 read1 <jpeg-color-info>
- swap [ >>id ] keep jpeg> color-info>> set-nth
- ] times
- ] with-byte-reader ;
-
-: decode-quant-table ( chunk -- )
- dup data>>
- binary
- [
- length>>
- 2 - 65 /
- [
- read4/4 [ 0 assert= ] dip
- 64 read
- swap jpeg> quant-tables>> set-nth
- ] times
- ] with-byte-reader ;
-
-: decode-huff-table ( chunk -- )
- data>> [ binary <byte-reader> ] [ length ] bi limit-stream [
- [ input-stream get stream>> [ count>> ] [ limit>> ] bi < ]
- [
- read4/4 swap 2 * +
- 16 read
- dup [ ] [ + ] map-reduce read
- binary [ [ read [ B{ } ] unless* ] { } map-as ] with-byte-reader
- swap jpeg> huff-tables>> set-nth
- ] while
- ] stream-throw-on-eof ;
-
-: decode-scan ( chunk -- )
- data>>
- binary
- [
- read1 iota
- [ drop
- read1 jpeg> color-info>> nth clone
- read1 16 /mod [ >>dc-huff-table ] [ >>ac-huff-table ] bi*
- ] map jpeg> components<<
- read1 0 assert=
- read1 63 assert=
- read1 16 /mod [ 0 assert= ] bi@
- ] with-byte-reader ;
-
-: singleton-first ( seq -- elt )
- [ length 1 assert= ] [ first ] bi ;
-
-ERROR: not-a-baseline-jpeg-image ;
-
-: baseline-parse ( -- )
- jpeg> headers>> [ type>> { SOF 0 } = ] any? [ not-a-baseline-jpeg-image ] unless
- jpeg> headers>>
- {
- [ [ type>> { SOF 0 } = ] filter singleton-first decode-frame ]
- [ [ type>> { DQT } = ] filter [ decode-quant-table ] each ]
- [ [ type>> { DHT } = ] filter [ decode-huff-table ] each ]
- [ [ type>> { SOS } = ] filter singleton-first decode-scan ]
- } cleave ;
-
-: parse-marker ( -- marker )
- read1 HEX: FF assert=
- read1 >marker ;
-
-: parse-headers ( -- chunks )
- [ parse-marker dup { SOS } = not ]
- [
- 2 read be>
- dup 2 - read <jpeg-chunk>
- ] [ produce ] keep dip swap suffix ;
-
-MEMO: zig-zag ( -- zz )
- {
- { 0 1 5 6 14 15 27 28 }
- { 2 4 7 13 16 26 29 42 }
- { 3 8 12 17 25 30 41 43 }
- { 9 11 18 24 31 40 44 53 }
- { 10 19 23 32 39 45 52 54 }
- { 20 22 33 38 46 51 55 60 }
- { 21 34 37 47 50 56 59 61 }
- { 35 36 48 49 57 58 62 63 }
- } flatten ;
-
-MEMO: yuv>bgr-matrix ( -- m )
- {
- { 1 2.03211 0 }
- { 1 -0.39465 -0.58060 }
- { 1 0 1.13983 }
- } ;
-
-: wave ( x u -- n ) swap 2 * 1 + * pi * 16 / cos ;
-
-:: dct-vect ( u v -- basis )
- { 8 8 } coord-matrix [ { u v } [ wave ] 2map product ] map^2
- 1 u v [ 0 = [ 2 sqrt / ] when ] bi@ 4 / m*n ;
-
-MEMO: dct-matrix ( -- m ) 64 iota [ 8 /mod dct-vect flatten ] map ;
-
-: mb-dim ( component -- dim ) [ h>> ] [ v>> ] bi 2array ;
-
-! : blocks ( component -- seq )
-! mb-dim ! coord-matrix flip concat [ [ { 2 2 } v* ] [ v+ ] bi* ] with map ;
-
-: all-macroblocks ( quot: ( mb -- ) -- )
- [
- jpeg>
- [ dim>> 8 v/n ]
- [ color-info>> sift { 0 0 } [ mb-dim vmax ] reduce v/ ] bi
- [ ceiling ] map
- coord-matrix flip concat
- ]
- [ each ] bi* ; inline
-
-: reverse-zigzag ( b -- b' ) zig-zag swap [ nth ] curry map ;
-
-: idct-factor ( b -- b' ) dct-matrix v.m ;
-
-MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
-: V.M ( x A -- x.A ) Mtranspose swap M.V ;
-: idct-blas ( b -- b' ) >float-blas-vector dct-matrix-blas V.M ;
-
-: idct ( b -- b' ) idct-factor ;
-
-:: draw-block ( block x,y color-id jpeg-image -- )
- block dup length>> sqrt >fixnum group flip
- dup matrix-dim coord-matrix flip
- [
- [ '[ _ [ second ] [ first ] bi ] dip nth nth ]
- [ x,y v+ color-id jpeg-image draw-color ] bi
- ] with each^2 ;
-
-: sign-extend ( bits v -- v' )
- swap [ ] [ 1 - 2^ < ] 2bi
- [ -1 swap shift 1 + + ] [ drop ] if ;
-
-: read1-jpeg-dc ( decoder -- dc )
- [ read1-huff dup ] [ bs>> bs:read ] bi sign-extend ;
-
-: read1-jpeg-ac ( decoder -- run/ac )
- [ read1-huff 16 /mod dup ] [ bs>> bs:read ] bi sign-extend 2array ;
-
-:: decode-block ( color -- pixels )
- color dc-huff-table>> read1-jpeg-dc color apply-diff
- 64 0 <array> :> coefs
- 0 coefs set-nth
- 0 :> k!
- [
- color ac-huff-table>> read1-jpeg-ac
- [ first 1 + k + k! ] [ second k coefs set-nth ] [ ] tri
- { 0 0 } = not
- k 63 < and
- ] loop
- coefs color quant-table>> v*
- reverse-zigzag idct ;
-
-:: draw-macroblock-yuv420 ( mb blocks -- )
- mb { 16 16 } v* :> pos
- 0 blocks nth pos { 0 0 } v+ 0 jpeg> draw-block
- 1 blocks nth pos { 8 0 } v+ 0 jpeg> draw-block
- 2 blocks nth pos { 0 8 } v+ 0 jpeg> draw-block
- 3 blocks nth pos { 8 8 } v+ 0 jpeg> draw-block
- 4 blocks nth 8 group 2 matrix-zoom concat pos 1 jpeg> draw-block
- 5 blocks nth 8 group 2 matrix-zoom concat pos 2 jpeg> draw-block ;
-
-:: draw-macroblock-yuv444 ( mb blocks -- )
- mb { 8 8 } v* :> pos
- 3 iota [ [ blocks nth pos ] [ jpeg> draw-block ] bi ] each ;
-
-:: draw-macroblock-y ( mb blocks -- )
- mb { 8 8 } v* :> pos
- 0 blocks nth pos 0 jpeg> draw-block
- 64 0 <array> pos 1 jpeg> draw-block
- 64 0 <array> pos 2 jpeg> draw-block ;
-
- ! %fixme: color hack
- ! color h>> 2 =
- ! [ 8 group 2 matrix-zoom concat ] unless
- ! pos { 8 8 } v* color jpeg> draw-block ;
-
-: decode-macroblock ( -- blocks )
- jpeg> components>>
- [
- [ mb-dim first2 * ]
- [ [ decode-block ] curry replicate ] bi
- ] map concat ;
-
-: cleanup-bitstream ( bytes -- bytes' )
- binary [
- [
- { HEX: FF } read-until
- read1 [ HEX: 00 = and ] keep swap
- ]
- [ drop ] produce
- swap >marker { EOI } assert=
- swap suffix
- { HEX: FF } join
- ] with-byte-reader ;
-
-: setup-bitmap ( image -- )
- dup dim>> 16 v/n [ ceiling ] map 16 v*n >>dim
- BGR >>component-order
- ubyte-components >>component-type
- f >>upside-down?
- dup dim>> first2 * 3 * 0 <array> >>bitmap
- drop ;
-
-ERROR: unsupported-colorspace ;
-SINGLETONS: YUV420 YUV444 Y MAGIC! ;
-
-:: detect-colorspace ( jpeg-image -- csp )
- jpeg-image color-info>> sift :> colors
- MAGIC!
- colors length 1 = [ drop Y ] when
- colors length 3 =
- [
- colors [ mb-dim { 1 1 } = ] all?
- [ drop YUV444 ] when
-
- colors unclip
- [ [ mb-dim { 1 1 } = ] all? ]
- [ mb-dim { 2 2 } = ] bi* and
- [ drop YUV420 ] when
- ] when ;
-
-! this eats ~50% cpu time
-: draw-macroblocks ( mbs -- )
- jpeg> detect-colorspace
- {
- { YUV420 [ [ first2 draw-macroblock-yuv420 ] each ] }
- { YUV444 [ [ first2 draw-macroblock-yuv444 ] each ] }
- { Y [ [ first2 draw-macroblock-y ] each ] }
- [ unsupported-colorspace ]
- } case ;
-
-! this eats ~25% cpu time
-: color-transform ( yuv -- rgb )
- { 128 0 0 } v+ yuv>bgr-matrix swap m.v
- [ 0 max 255 min >fixnum ] map ;
-
-: baseline-decompress ( -- )
- jpeg> bitstream>> cleanup-bitstream { 255 255 255 255 } append
- >byte-array bs:<msb0-bit-reader> jpeg> bitstream<<
- jpeg>
- [ bitstream>> ]
- [ [ [ <huffman-decoder> ] with map ] change-huff-tables drop ] bi
- jpeg> components>> [ fetch-tables ] each
- [ decode-macroblock 2array ] collector
- [ all-macroblocks ] dip
- jpeg> setup-bitmap draw-macroblocks
- jpeg> bitmap>> 3 <groups> [ color-transform ] map! drop
- jpeg> [ >byte-array ] change-bitmap drop ;
-
-ERROR: not-a-jpeg-image ;
-
-: loading-jpeg>image ( loading-jpeg -- image )
- dup jpeg-image [
- baseline-parse
- baseline-decompress
- ] with-variable ;
-
-: load-jpeg ( stream -- loading-jpeg )
- [
- parse-marker { SOI } = [ not-a-jpeg-image ] unless
- parse-headers
- contents <loading-jpeg>
- ] with-input-stream ;
-
-PRIVATE>
-
-M: jpeg-image stream>image ( stream jpeg-image -- bitmap )
- drop load-jpeg loading-jpeg>image ;
+++ /dev/null
-Erik Charlebois
+++ /dev/null
-! Copyright (C) 2010 Erik Charlebois.
-! See http://factorcode.org/license.txt for BSD license.
-USING: images.testing ;
-IN: images.pbm.tests
-
-"vocab:images/testing/pbm/test.binary.pbm" decode-test
-"vocab:images/testing/pbm/test.ascii.pbm" decode-test
+++ /dev/null
-! Copyright (C) 2010 Erik Charlebois.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays ascii bit-arrays byte-arrays combinators
-continuations grouping images images.loader io io.encodings.ascii
-io.encodings.string kernel locals make math math.functions math.parser
-sequences io.streams.throwing ;
-IN: images.pbm
-
-SINGLETON: pbm-image
-"pbm" pbm-image register-image-class
-
-<PRIVATE
-: read-token ( -- token )
- [
- read1 dup blank?
- [ t ]
- [
- dup CHAR: # =
- [ "\n" read-until 2drop t ]
- [ f ] if
- ] if
- ] [ drop ] while
- " \n\r\t" read-until drop swap
- prefix ascii decode ;
-
-: read-number ( -- number )
- read-token string>number ;
-
-: read-ascii-bits ( -- )
- read1 {
- { CHAR: 1 [ 0 , read-ascii-bits ] }
- { CHAR: 0 [ 255 , read-ascii-bits ] }
- { f [ ] }
- [ drop read-ascii-bits ]
- } case ;
-
-:: read-binary-bits ( width height -- )
- width 8 align 8 / height * read
- width 8 align 8 / <groups> [| row |
- width iota [| n |
- n 8 / floor row nth
- n 8 mod 7 swap - bit?
- [ 0 ] [ 255 ] if ,
- ] each
- ] each ;
-
-:: write-binary-bits ( bitmap width -- )
- bitmap width <groups> [
- width 8 align 255 pad-tail
- 8 <groups> [
- [ 255 = [ f ] [ t ] if ] { } map-as
- >bit-array reverse bit-array>integer
- 1array >byte-array write
- ] each
- ] each ;
-
-:: read-pbm ( -- image )
- read-token :> type
- read-number :> width
- read-number :> height
-
- type {
- { "P1" [ [ [ read-ascii-bits ] ignore-errors ] B{ } make ] }
- { "P4" [ [ width height read-binary-bits ] B{ } make ] }
- } case :> data
-
- image new
- L >>component-order
- { width height } >>dim
- f >>upside-down?
- data >>bitmap
- ubyte-components >>component-type ;
-PRIVATE>
-
-M: pbm-image stream>image
- drop [ [ read-pbm ] throw-on-eof ] with-input-stream ;
-
-M: pbm-image image>stream
- drop {
- [ drop "P4\n" ascii encode write ]
- [ dim>> first number>string " " append ascii encode write ]
- [ dim>> second number>string "\n" append ascii encode write ]
- [ [ bitmap>> ] [ dim>> first ] bi write-binary-bits ]
- } cleave ;
+++ /dev/null
-Image loading for PBM image files.
+++ /dev/null
-Erik Charlebois
+++ /dev/null
-! Copyright (C) 2010 Erik Charlebois.
-! See http://factorcode.org/license.txt for BSD license.
-USING: images.testing ;
-IN: images.pgm.tests
-
-"vocab:images/testing/pgm/radial.binary.pgm" decode-test
-"vocab:images/testing/pgm/radial.ascii.pgm" decode-test
+++ /dev/null
-! Copyright (C) 2010 Erik Charlebois.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types ascii combinators images images.loader
-io io.encodings.ascii io.encodings.string kernel locals make math
-math.parser sequences specialized-arrays io.streams.throwing ;
-SPECIALIZED-ARRAY: ushort
-IN: images.pgm
-
-SINGLETON: pgm-image
-"pgm" pgm-image register-image-class
-
-: read-token ( -- token )
- [ read1 dup blank?
- [ t ]
- [ dup CHAR: # =
- [ "\n" read-until 2drop t ]
- [ f ] if
- ] if
- ] [ drop ] while
- " \n\r\t" read-until drop swap
- prefix ascii decode ;
-
-: read-number ( -- number )
- read-token string>number ;
-
-:: read-numbers ( n lim -- )
- n lim = [
- read-number ,
- n 1 + lim read-numbers
- ] unless ;
-
-:: read-pgm ( -- image )
- read-token :> type
- read-number :> width
- read-number :> height
- read-number :> max
- width height * :> npixels
- max 256 >= :> wide
-
- type {
- { "P2" [ [ 0 npixels read-numbers ] wide [ ushort-array{ } ] [ B{ } ] if make ] }
- { "P5" [ wide [ 2 ] [ 1 ] if npixels * read ] }
- } case :> data
-
- image new
- L >>component-order
- { width height } >>dim
- f >>upside-down?
- data >>bitmap
- wide [ ushort-components ] [ ubyte-components ] if >>component-type ;
-
-M: pgm-image stream>image
- drop [ [ read-pgm ] throw-on-eof ] with-input-stream ;
-
-M: pgm-image image>stream
- drop {
- [ drop "P5\n" ascii encode write ]
- [ dim>> first number>string " " append ascii encode write ]
- [ dim>> second number>string "\n" append ascii encode write ]
- [ component-type>> ubyte-components = [ "255\n" ] [ "65535\n" ] if ascii encode write ]
- [ bitmap>> write ]
- } cleave ;
+++ /dev/null
-Image loading for PGM image files.
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! Copyright (C) 2009 Doug Coleman, Keith Lazuka
-! See http://factorcode.org/license.txt for BSD license.
-USING: images.testing io.directories ;
-IN: images.png.tests
-
-! Test files from PngSuite (http://www.libpng.org/pub/png/pngsuite.html)
-
-! The subset of the suite that should work given the current implementation.
-"vocab:images/testing/png" [
- "basi0g01.png" decode-test
- "basi0g02.png" decode-test
- "basi0g04.png" decode-test
- "basi0g08.png" decode-test
- "basi0g16.png" decode-test
- "basi2c08.png" decode-test
- "basi3p01.png" decode-test
- "basi3p02.png" decode-test
- "basi3p04.png" decode-test
- "basi3p08.png" decode-test
- "basn0g01.png" decode-test
- "basn0g02.png" decode-test
- "basn0g04.png" decode-test
- "basn0g08.png" decode-test
- "basn0g16.png" decode-test
- "basn2c08.png" decode-test
- "basn3p01.png" decode-test
- "basn3p02.png" decode-test
- "basn3p04.png" decode-test
- "basn3p08.png" decode-test
- "basn6a08.png" decode-test
- "f00n2c08.png" decode-test
- "f01n2c08.png" decode-test
- "f02n2c08.png" decode-test
- "f03n2c08.png" decode-test
- "f04n2c08.png" decode-test
- "s01i3p01.png" decode-test
- "s01n3p01.png" decode-test
- "s02i3p01.png" decode-test
- "s02n3p01.png" decode-test
- "s03i3p01.png" decode-test
- "s03n3p01.png" decode-test
- "s04i3p01.png" decode-test
- "s04n3p01.png" decode-test
- "s05i3p02.png" decode-test
- "s05n3p02.png" decode-test
- "s06i3p02.png" decode-test
- "s06n3p02.png" decode-test
- "s07i3p02.png" decode-test
- "s07n3p02.png" decode-test
- "s08i3p02.png" decode-test
- "s08n3p02.png" decode-test
- "s09i3p02.png" decode-test
- "s32n3p04.png" decode-test
- "s32i3p04.png" decode-test
- "s33n3p04.png" decode-test
- "s33i3p04.png" decode-test
- "s34n3p04.png" decode-test
- "s34i3p04.png" decode-test
- "s35n3p04.png" decode-test
- "s35i3p04.png" decode-test
- "s36n3p04.png" decode-test
- "s36i3p04.png" decode-test
- "s37n3p04.png" decode-test
- "s37i3p04.png" decode-test
- "s38n3p04.png" decode-test
- "s38i3p04.png" decode-test
- "s39n3p04.png" decode-test
- "s39i3p04.png" decode-test
- "s40n3p04.png" decode-test
- "s40i3p04.png" decode-test
- "s07n3p02.png" decode-test
- "z00n2c08.png" decode-test
- "z03n2c08.png" decode-test
- "z06n2c08.png" decode-test
- "z09n2c08.png" decode-test
-] with-directory
-
-! The current PNG decoder implementation is very limited,
-! so the entire test suite is not currently enabled.
-! "vocab:images/testing/png/suite" [
-! "basi0g01.png" decode-test
-! "basi0g02.png" decode-test
-! "basi0g04.png" decode-test
-! "basi0g08.png" decode-test
-! "basi0g16.png" decode-test
-! "basi2c08.png" decode-test
-! "basi2c16.png" decode-test
-! "basi3p01.png" decode-test
-! "basi3p02.png" decode-test
-! "basi3p04.png" decode-test
-! "basi3p08.png" decode-test
-! "basi4a08.png" decode-test
-! "basi4a16.png" decode-test
-! "basi6a08.png" decode-test
-! "basi6a16.png" decode-test
-! "basn0g01.png" decode-test
-! "basn0g02.png" decode-test
-! "basn0g04.png" decode-test
-! "basn0g08.png" decode-test
-! "basn0g16.png" decode-test
-! "basn2c08.png" decode-test
-! "basn2c16.png" decode-test
-! "basn3p01.png" decode-test
-! "basn3p02.png" decode-test
-! "basn3p04.png" decode-test
-! "basn3p08.png" decode-test
-! "basn4a08.png" decode-test
-! "basn4a16.png" decode-test
-! "basn6a08.png" decode-test
-! "basn6a16.png" decode-test
-! "bgai4a08.png" decode-test
-! "bgai4a16.png" decode-test
-! "bgan6a08.png" decode-test
-! "bgan6a16.png" decode-test
-! "bgbn4a08.png" decode-test
-! "bggn4a16.png" decode-test
-! "bgwn6a08.png" decode-test
-! "bgyn6a16.png" decode-test
-! "ccwn2c08.png" decode-test
-! "ccwn3p08.png" decode-test
-! "cdfn2c08.png" decode-test
-! "cdhn2c08.png" decode-test
-! "cdsn2c08.png" decode-test
-! "cdun2c08.png" decode-test
-! "ch1n3p04.png" decode-test
-! "ch2n3p08.png" decode-test
-! "cm0n0g04.png" decode-test
-! "cm7n0g04.png" decode-test
-! "cm9n0g04.png" decode-test
-! "cs3n2c16.png" decode-test
-! "cs3n3p08.png" decode-test
-! "cs5n2c08.png" decode-test
-! "cs5n3p08.png" decode-test
-! "cs8n2c08.png" decode-test
-! "cs8n3p08.png" decode-test
-! "ct0n0g04.png" decode-test
-! "ct1n0g04.png" decode-test
-! "ctzn0g04.png" decode-test
-! "f00n0g08.png" decode-test
-! "f00n2c08.png" decode-test
-! "f01n0g08.png" decode-test
-! "f01n2c08.png" decode-test
-! "f02n0g08.png" decode-test
-! "f02n2c08.png" decode-test
-! "f03n0g08.png" decode-test
-! "f03n2c08.png" decode-test
-! "f04n0g08.png" decode-test
-! "f04n2c08.png" decode-test
-! "g03n0g16.png" decode-test
-! "g03n2c08.png" decode-test
-! "g03n3p04.png" decode-test
-! "g04n0g16.png" decode-test
-! "g04n2c08.png" decode-test
-! "g04n3p04.png" decode-test
-! "g05n0g16.png" decode-test
-! "g05n2c08.png" decode-test
-! "g05n3p04.png" decode-test
-! "g07n0g16.png" decode-test
-! "g07n2c08.png" decode-test
-! "g07n3p04.png" decode-test
-! "g10n0g16.png" decode-test
-! "g10n2c08.png" decode-test
-! "g10n3p04.png" decode-test
-! "g25n0g16.png" decode-test
-! "g25n2c08.png" decode-test
-! "g25n3p04.png" decode-test
-! "oi1n0g16.png" decode-test
-! "oi1n2c16.png" decode-test
-! "oi2n0g16.png" decode-test
-! "oi2n2c16.png" decode-test
-! "oi4n0g16.png" decode-test
-! "oi4n2c16.png" decode-test
-! "oi9n0g16.png" decode-test
-! "oi9n2c16.png" decode-test
-! "pngsuite_logo.png" decode-test
-! "pp0n2c16.png" decode-test
-! "pp0n6a08.png" decode-test
-! "ps1n0g08.png" decode-test
-! "ps1n2c16.png" decode-test
-! "ps2n0g08.png" decode-test
-! "ps2n2c16.png" decode-test
-! "s01i3p01.png" decode-test
-! "s01n3p01.png" decode-test
-! "s02i3p01.png" decode-test
-! "s02n3p01.png" decode-test
-! "s03i3p01.png" decode-test
-! "s03n3p01.png" decode-test
-! "s04i3p01.png" decode-test
-! "s04n3p01.png" decode-test
-! "s05i3p02.png" decode-test
-! "s05n3p02.png" decode-test
-! "s06i3p02.png" decode-test
-! "s06n3p02.png" decode-test
-! "s07i3p02.png" decode-test
-! "s07n3p02.png" decode-test
-! "s08i3p02.png" decode-test
-! "s08n3p02.png" decode-test
-! "s09i3p02.png" decode-test
-! "s09n3p02.png" decode-test
-! "s32i3p04.png" decode-test
-! "s32n3p04.png" decode-test
-! "s33i3p04.png" decode-test
-! "s33n3p04.png" decode-test
-! "s34i3p04.png" decode-test
-! "s34n3p04.png" decode-test
-! "s35i3p04.png" decode-test
-! "s35n3p04.png" decode-test
-! "s36i3p04.png" decode-test
-! "s36n3p04.png" decode-test
-! "s37i3p04.png" decode-test
-! "s37n3p04.png" decode-test
-! "s38i3p04.png" decode-test
-! "s38n3p04.png" decode-test
-! "s39i3p04.png" decode-test
-! "s39n3p04.png" decode-test
-! "s40i3p04.png" decode-test
-! "s40n3p04.png" decode-test
-! "tbbn1g04.png" decode-test
-! "tbbn2c16.png" decode-test
-! "tbbn3p08.png" decode-test
-! "tbgn2c16.png" decode-test
-! "tbgn3p08.png" decode-test
-! "tbrn2c08.png" decode-test
-! "tbwn1g16.png" decode-test
-! "tbwn3p08.png" decode-test
-! "tbyn3p08.png" decode-test
-! "tp0n1g08.png" decode-test
-! "tp0n2c08.png" decode-test
-! "tp0n3p08.png" decode-test
-! "tp1n3p08.png" decode-test
-! "x00n0g01.png" decode-test
-! "xcrn0g04.png" decode-test
-! "xlfn0g04.png" decode-test
-! "z00n2c08.png" decode-test
-! "z03n2c08.png" decode-test
-! "z06n2c08.png" decode-test
-! "z09n2c08.png" decode-test
-! ] with-directory
+++ /dev/null
-! Copyright (C) 2009 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays checksums checksums.crc32 combinators
-compression.inflate fry grouping images images.loader io
-io.binary io.encodings.ascii io.encodings.string kernel locals
-math math.bitwise math.ranges sequences sorting assocs
-math.functions math.order byte-arrays io.streams.throwing ;
-QUALIFIED-WITH: bitstreams bs
-IN: images.png
-
-SINGLETON: png-image
-"png" png-image register-image-class
-
-TUPLE: loading-png
- chunks
- width height bit-depth color-type compression-method
- filter-method interlace-method uncompressed ;
-
-CONSTANT: filter-none 0
-CONSTANT: filter-sub 1
-CONSTANT: filter-up 2
-CONSTANT: filter-average 3
-CONSTANT: filter-paeth 4
-
-CONSTANT: greyscale 0
-CONSTANT: truecolor 2
-CONSTANT: indexed-color 3
-CONSTANT: greyscale-alpha 4
-CONSTANT: truecolor-alpha 6
-
-CONSTANT: interlace-none 0
-CONSTANT: interlace-adam7 1
-
-CONSTANT: starting-row { 0 0 4 0 2 0 1 }
-CONSTANT: starting-col { 0 4 0 2 0 1 0 }
-CONSTANT: row-increment { 8 8 8 4 4 2 2 }
-CONSTANT: col-increment { 8 8 4 4 2 2 1 }
-CONSTANT: block-height { 8 8 4 4 2 2 1 }
-CONSTANT: block-width { 8 4 4 2 2 1 1 }
-
-: <loading-png> ( -- image )
- loading-png new
- V{ } clone >>chunks ;
-
-TUPLE: png-chunk length type data ;
-
-: <png-chunk> ( -- png-chunk )
- png-chunk new ; inline
-
-CONSTANT: png-header
- B{ HEX: 89 HEX: 50 HEX: 4e HEX: 47 HEX: 0d HEX: 0a HEX: 1a HEX: 0a }
-
-ERROR: bad-png-header header ;
-
-: read-png-header ( -- )
- 8 read dup png-header sequence= [
- bad-png-header
- ] unless drop ;
-
-ERROR: bad-checksum ;
-
-: read-png-chunks ( loading-png -- loading-png )
- <png-chunk>
- 4 read be> [ >>length ] [ 4 + ] bi
- read dup crc32 checksum-bytes
- 4 read = [ bad-checksum ] unless
- 4 cut-slice
- [ ascii decode >>type ] [ B{ } like >>data ] bi*
- [ over chunks>> push ]
- [ type>> ] bi "IEND" =
- [ read-png-chunks ] unless ;
-
-: find-chunk ( loading-png string -- chunk )
- [ chunks>> ] dip '[ type>> _ = ] find nip ;
-
-: find-chunks ( loading-png string -- chunk )
- [ chunks>> ] dip '[ type>> _ = ] filter ;
-
-: parse-ihdr-chunk ( loading-png -- loading-png )
- dup "IHDR" find-chunk data>> {
- [ [ 0 4 ] dip subseq be> >>width ]
- [ [ 4 8 ] dip subseq be> >>height ]
- [ [ 8 ] dip nth >>bit-depth ]
- [ [ 9 ] dip nth >>color-type ]
- [ [ 10 ] dip nth >>compression-method ]
- [ [ 11 ] dip nth >>filter-method ]
- [ [ 12 ] dip nth >>interlace-method ]
- } cleave ;
-
-: find-compressed-bytes ( loading-png -- bytes )
- "IDAT" find-chunks [ data>> ] map concat ;
-
-ERROR: unknown-color-type n ;
-ERROR: unimplemented-color-type image ;
-
-: inflate-data ( loading-png -- bytes )
- find-compressed-bytes zlib-inflate ;
-
-: png-components-per-pixel ( loading-png -- n )
- color-type>> {
- { greyscale [ 1 ] }
- { truecolor [ 3 ] }
- { greyscale-alpha [ 2 ] }
- { indexed-color [ 1 ] }
- { truecolor-alpha [ 4 ] }
- [ unknown-color-type ]
- } case ; inline
-
-: png-group-width ( loading-png -- n )
- ! 1 + is for the filter type, 1 byte preceding each line
- [ [ png-components-per-pixel ] [ bit-depth>> ] bi * ]
- [ width>> ] bi * 1 + ;
-
-:: paeth ( a b c -- p )
- a b + c - { a b c } [ [ - abs ] keep 2array ] with map
- sort-keys first second ;
-
-:: png-unfilter-line ( width prev curr filter -- curr' )
- prev :> c
- prev width tail-slice :> b
- curr :> a
- curr width tail-slice :> x
- x length iota
- filter {
- { filter-none [ drop ] }
- { filter-sub [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] }
- { filter-up [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] }
- { filter-average [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] }
- { filter-paeth [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] }
- } case
- curr width tail ;
-
-:: reverse-png-filter ( lines n -- byte-array )
- lines dup first length 0 <array> prefix
- [ n 1 - 0 <array> prepend ] map
- 2 clump [
- n swap first2
- [ ]
- [ n 1 - swap nth ]
- [ [ 0 n 1 - ] dip set-nth ] tri
- png-unfilter-line
- ] map B{ } concat-as ;
-
-:: visit ( row col height width pixel image -- )
- row image nth :> irow
- pixel col irow set-nth ;
-
-ERROR: bad-filter n ;
-
-:: read-scanlines ( bit-reader loading-png width height -- array )
- loading-png png-components-per-pixel :> #components
- loading-png bit-depth>> :> bit-depth
- bit-depth :> depth!
- #components width * :> count!
-
- ! Only read up to 8 bits at a time
- bit-depth 16 = [
- 8 depth!
- count 2 * count!
- ] when
-
- height [
- 8 bit-reader bs:read dup 0 4 between? [ bad-filter ] unless
- count [ depth bit-reader bs:read ] replicate swap prefix
- 8 bit-reader bs:align
- ] replicate
- #components bit-depth 16 = [ 2 * ] when reverse-png-filter ;
-
-:: reverse-interlace-none ( byte-array loading-png -- array )
- byte-array bs:<msb0-bit-reader> :> bs
- loading-png width>> :> width
- loading-png height>> :> height
- bs loading-png width height read-scanlines ;
-
-:: adam7-subimage-height ( png-height pass -- subimage-height )
- pass starting-row nth png-height >= [
- 0
- ] [
- png-height 1 -
- pass block-height nth +
- pass row-increment nth /i
- ] if ;
-
-:: adam7-subimage-width ( png-width pass -- subimage-width )
- pass starting-col nth png-width >= [
- 0
- ] [
- png-width 1 -
- pass block-width nth +
- pass col-increment nth /i
- ] if ;
-
-:: read-adam7-subimage ( bit-reader loading-png pass -- lines )
- loading-png height>> pass adam7-subimage-height :> height
- loading-png width>> pass adam7-subimage-width :> width
-
- height width * zero? [
- B{ } clone
- ] [
- bit-reader loading-png width height read-scanlines
- ] if ;
-
-:: reverse-interlace-adam7 ( byte-array loading-png -- byte-array )
- byte-array bs:<msb0-bit-reader> :> bs
- loading-png height>> :> height
- loading-png width>> :> width
- loading-png bit-depth>> :> bit-depth
- loading-png png-components-per-pixel :> #bytes!
- width height * f <array> width <sliced-groups> :> image
-
- bit-depth 16 = [
- #bytes 2 * #bytes!
- ] when
-
- 0 :> row!
- 0 :> col!
-
- 0 :> pass!
- [ pass 7 < ] [
- bs loading-png pass read-adam7-subimage
-
- #bytes <sliced-groups>
-
- pass starting-row nth row!
- pass starting-col nth col!
- [
- [ row col f f ] dip image visit
-
- col pass col-increment nth + col!
- col width >= [
- pass starting-col nth col!
- row pass row-increment nth + row!
- ] when
- ] each
-
- pass 1 + pass!
- ] while
- image concat B{ } concat-as ;
-
-ERROR: unimplemented-interlace ;
-
-: uncompress-bytes ( loading-png -- bitstream )
- [ inflate-data ] [ ] [ interlace-method>> ] tri {
- { interlace-none [ reverse-interlace-none ] }
- { interlace-adam7 [ reverse-interlace-adam7 ] }
- [ unimplemented-interlace ]
- } case ;
-
-ERROR: unknown-component-type n ;
-
-: png-component ( loading-png -- obj )
- bit-depth>> {
- { 1 [ ubyte-components ] }
- { 2 [ ubyte-components ] }
- { 4 [ ubyte-components ] }
- { 8 [ ubyte-components ] }
- { 16 [ ushort-components ] }
- [ unknown-component-type ]
- } case ;
-
-: scale-factor ( n -- n' )
- {
- { 1 [ 255 ] }
- { 2 [ 85 ] }
- { 4 [ 17 ] }
- } case ;
-
-: scale-greyscale ( byte-array loading-png -- byte-array' )
- bit-depth>> {
- { 8 [ ] }
- { 16 [ 2 group [ swap ] assoc-map B{ } concat-as ] }
- [ scale-factor '[ _ * ] B{ } map-as ]
- } case ;
-
-: decode-greyscale ( loading-png -- byte-array )
- [ uncompress-bytes ] keep scale-greyscale ;
-
-: decode-greyscale-alpha ( loading-image -- byte-array )
- [ uncompress-bytes ] [ bit-depth>> ] bi 16 = [
- 4 group [ first4 [ swap ] 2dip 4array ] map B{ } concat-as
- ] when ;
-
-ERROR: invalid-PLTE array ;
-
-: verify-PLTE ( seq -- seq )
- dup length 3 divisor? [ invalid-PLTE ] unless ;
-
-: decode-indexed-color ( loading-image -- byte-array )
- [ uncompress-bytes ] keep
- "PLTE" find-chunk data>> verify-PLTE
- 3 group '[ _ nth ] { } map-as B{ } concat-as ;
-
-ERROR: invalid-color-type/bit-depth loading-png ;
-
-: validate-bit-depth ( loading-png seq -- loading-png )
- [ dup bit-depth>> ] dip member?
- [ invalid-color-type/bit-depth ] unless ;
-
-: validate-greyscale ( loading-png -- loading-png )
- { 1 2 4 8 16 } validate-bit-depth ;
-
-: validate-truecolor ( loading-png -- loading-png )
- { 8 16 } validate-bit-depth ;
-
-: validate-indexed-color ( loading-png -- loading-png )
- { 1 2 4 8 } validate-bit-depth ;
-
-: validate-greyscale-alpha ( loading-png -- loading-png )
- { 8 16 } validate-bit-depth ;
-
-: validate-truecolor-alpha ( loading-png -- loading-png )
- { 8 16 } validate-bit-depth ;
-
-: loading-png>bitmap ( loading-png -- bytes component-order )
- dup color-type>> {
- { greyscale [
- validate-greyscale decode-greyscale L
- ] }
- { truecolor [
- validate-truecolor uncompress-bytes RGB
- ] }
- { indexed-color [
- validate-indexed-color decode-indexed-color RGB
- ] }
- { greyscale-alpha [
- validate-greyscale-alpha decode-greyscale-alpha LA
- ] }
- { truecolor-alpha [
- validate-truecolor-alpha uncompress-bytes RGBA
- ] }
- [ unknown-color-type ]
- } case ;
-
-: loading-png>image ( loading-png -- image )
- [ image new ] dip {
- [ loading-png>bitmap [ >>bitmap ] [ >>component-order ] bi* ]
- [ [ width>> ] [ height>> ] bi 2array >>dim ]
- [ png-component >>component-type ]
- } cleave ;
-
-: load-png ( stream -- loading-png )
- [
- [
- <loading-png>
- read-png-header
- read-png-chunks
- parse-ihdr-chunk
- ] throw-on-eof
- ] with-input-stream ;
-
-M: png-image stream>image
- drop load-png loading-png>image ;
+++ /dev/null
-Erik Charlebois
+++ /dev/null
-! Copyright (C) 2010 Erik Charlebois.
-! See http://factorcode.org/license.txt for BSD license.
-USING: images.testing ;
-IN: images.ppm.tests
-
-"vocab:images/testing/ppm/binary.ppm" decode-test
-"vocab:images/testing/ppm/ascii.ppm" decode-test
+++ /dev/null
-! Copyright (C) 2010 Erik Charlebois.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors ascii combinators images images.loader io
-io.encodings.ascii io.encodings.string kernel locals make math
-math.parser sequences io.streams.throwing ;
-IN: images.ppm
-
-SINGLETON: ppm-image
-"ppm" ppm-image register-image-class
-
-: read-token ( -- token )
- [ read1 dup blank?
- [ t ]
- [ dup CHAR: # =
- [ "\n" read-until 2drop t ]
- [ f ] if
- ] if
- ] [ drop ] while
- " \n\r\t" read-until drop swap
- prefix ascii decode ;
-
-: read-number ( -- number )
- read-token string>number ;
-
-:: read-numbers ( n lim -- )
- n lim = [
- read-number ,
- n 1 + lim read-numbers
- ] unless ;
-
-:: read-ppm ( -- image )
- read-token :> type
- read-number :> width
- read-number :> height
- read-number :> max
- width height 3 * * :> npixels
- type {
- { "P3" [ [ 0 npixels read-numbers ] B{ } make ] }
- { "P6" [ npixels read ] }
- } case :> data
-
- image new
- RGB >>component-order
- { width height } >>dim
- f >>upside-down?
- data >>bitmap
- ubyte-components >>component-type ;
-
-M: ppm-image stream>image
- drop [ [ read-ppm ] throw-on-eof ] with-input-stream ;
-
-M: ppm-image image>stream
- drop {
- [ drop "P6\n" ascii encode write ]
- [ dim>> first number>string " " append ascii encode write ]
- [ dim>> second number>string "\n" append ascii encode write ]
- [ drop "255\n" ascii encode write ]
- [ bitmap>> write ]
- } cleave ;
+++ /dev/null
-Image loading for PPM image files.
+++ /dev/null
-Erik Charlebois
+++ /dev/null
-! Copyright (C) 2010 Erik Charlebois
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors images images.loader io io.binary kernel
-locals math sequences io.encodings.ascii io.encodings.string
-calendar math.ranges math.parser colors arrays hashtables
-ui.pixel-formats combinators continuations io.streams.throwing ;
-IN: images.tga
-
-SINGLETON: tga-image
-"tga" tga-image register-image-class
-
-ERROR: bad-tga-header ;
-ERROR: bad-tga-footer ;
-ERROR: bad-tga-extension-size ;
-ERROR: bad-tga-timestamp ;
-ERROR: bad-tga-unsupported ;
-
-: read-id-length ( -- byte )
- 1 read le> ; inline
-
-: read-color-map-type ( -- byte )
- 1 read le> dup
- { 0 1 } member? [ bad-tga-header ] unless ;
-
-: read-image-type ( -- byte )
- 1 read le> dup
- { 0 1 2 3 9 10 11 } member? [ bad-tga-header ] unless ; inline
-
-: read-color-map-first ( -- short )
- 2 read le> ; inline
-
-: read-color-map-length ( -- short )
- 2 read le> ; inline
-
-: read-color-map-entry-size ( -- byte )
- 1 read le> ; inline
-
-: read-x-origin ( -- short )
- 2 read le> ; inline
-
-: read-y-origin ( -- short )
- 2 read le> ; inline
-
-: read-image-width ( -- short )
- 2 read le> ; inline
-
-: read-image-height ( -- short )
- 2 read le> ; inline
-
-: read-pixel-depth ( -- byte )
- 1 read le> ; inline
-
-: read-image-descriptor ( -- alpha-bits pixel-order )
- 1 read le>
- [ 7 bitand ] [ 24 bitand -3 shift ] bi ; inline
-
-: read-image-id ( length -- image-id )
- read ; inline
-
-: read-color-map ( type length elt-size -- color-map )
- pick 1 = [ 8 align 8 / * read ] [ 2drop f ] if swap drop ; inline
-
-: read-image-data ( width height depth -- image-data )
- 8 align 8 / * * read ; inline
-
-: read-extension-area-offset ( -- offset )
- 4 read le> ; inline
-
-: read-developer-directory-offset ( -- offset )
- 4 read le> ; inline
-
-: read-signature ( -- )
- 18 read ascii decode "TRUEVISION-XFILE.\0" = [ bad-tga-footer ] unless ; inline
-
-: read-extension-size ( -- )
- 2 read le> 495 = [ bad-tga-extension-size ] unless ; inline
-
-: read-author-name ( -- string )
- 41 read ascii decode [ 0 = ] trim ; inline
-
-: read-author-comments ( -- string )
- 4 iota [ drop 81 read ascii decode [ 0 = ] trim ] map concat ; inline
-
-: read-date-timestamp ( -- timestamp )
- timestamp new
- 2 read le> dup 12 [1,b] member? [ bad-tga-timestamp ] unless >>month
- 2 read le> dup 31 [1,b] member? [ bad-tga-timestamp ] unless >>day
- 2 read le> >>year
- 2 read le> dup 23 [0,b] member? [ bad-tga-timestamp ] unless >>hour
- 2 read le> dup 59 [0,b] member? [ bad-tga-timestamp ] unless >>minute
- 2 read le> dup 59 [0,b] member? [ bad-tga-timestamp ] unless >>second ; inline
-
-: read-job-name ( -- string )
- 41 read ascii decode [ 0 = ] trim ; inline
-
-: read-job-time ( -- duration )
- duration new
- 2 read le> >>hour
- 2 read le> dup 59 [0,b] member? [ bad-tga-timestamp ] unless >>minute
- 2 read le> dup 59 [0,b] member? [ bad-tga-timestamp ] unless >>second ; inline
-
-: read-software-id ( -- string )
- 41 read ascii decode [ 0 = ] trim ; inline
-
-: read-software-version ( -- string )
- 2 read le> 100 /f number>string
- 1 read ascii decode append [ " " = ] trim ; inline
-
-:: read-key-color ( -- color )
- 1 read le> 255 /f :> alpha
- 1 read le> 255 /f
- 1 read le> 255 /f
- 1 read le> 255 /f
- alpha <rgba> ; inline
-
-: read-pixel-aspect-ratio ( -- aspect-ratio )
- 2 read le> 2 read le> /f ; inline
-
-: read-gamma-value ( -- gamma-value )
- 2 read le> 2 read le> /f ; inline
-
-: read-color-correction-offset ( -- offset )
- 4 read le> ; inline
-
-: read-postage-stamp-offset ( -- offset )
- 4 read le> ; inline
-
-: read-scan-line-offset ( -- offset )
- 4 read le> ; inline
-
-: read-premultiplied-alpha ( -- boolean )
- 1 read le> 4 = ; inline
-
-: read-scan-line-table ( height -- scan-offsets )
- iota [ drop 4 read le> ] map ; inline
-
-: read-postage-stamp-image ( depth -- postage-data )
- 8 align 8 / 1 read le> 1 read le> * * read ; inline
-
-:: read-color-correction-table ( -- correction-table )
- 256 iota
- [
- drop
- 4 iota
- [
- drop
- 2 read le> 65535 /f :> alpha
- 2 read le> 65535 /f
- 2 read le> 65535 /f
- 2 read le> 65535 /f
- alpha <rgba>
- ] map
- ] map ; inline
-
-: read-developer-directory ( -- developer-directory )
- 2 read le> iota
- [
- drop
- 2 read le>
- 4 read le>
- 4 read le>
- 3array
- ] map ; inline
-
-: read-developer-areas ( developer-directory -- developer-area-map )
- [
- [ first ]
- [ dup third second seek-absolute seek-input read ] bi 2array
- ] map >hashtable ; inline
-
-:: read-tga ( -- image )
- #! Read header
- read-id-length :> id-length
- read-color-map-type :> map-type
- read-image-type :> image-type
- read-color-map-first :> map-first
- read-color-map-length :> map-length
- read-color-map-entry-size :> map-entry-size
- read-x-origin :> x-origin
- read-y-origin :> y-origin
- read-image-width :> image-width
- read-image-height :> image-height
- read-pixel-depth :> pixel-depth
- read-image-descriptor :> ( alpha-bits pixel-order )
- id-length read-image-id :> image-id
- map-type map-length map-entry-size read-color-map :> color-map-data
- image-width image-height pixel-depth read-image-data :> image-data
-
- [
- #! Read optional footer
- 26 seek-end seek-input
- read-extension-area-offset :> extension-offset
- read-developer-directory-offset :> directory-offset
- read-signature
-
- #! Read optional extension section
- extension-offset 0 =
- [
- extension-offset seek-absolute seek-input
- read-extension-size
- read-author-name :> author-name
- read-author-comments :> author-comments
- read-date-timestamp :> date-timestamp
- read-job-name :> job-name
- read-job-time :> job-time
- read-software-id :> software-id
- read-software-version :> software-version
- read-key-color :> key-color
- read-pixel-aspect-ratio :> aspect-ratio
- read-gamma-value :> gamma-value
- read-color-correction-offset :> color-correction-offset
- read-postage-stamp-offset :> postage-stamp-offset
- read-scan-line-offset :> scan-line-offset
- read-premultiplied-alpha :> premultiplied-alpha
-
- color-correction-offset 0 =
- [
- color-correction-offset seek-absolute seek-input
- read-color-correction-table :> color-correction-table
- ] unless
-
- postage-stamp-offset 0 =
- [
- postage-stamp-offset seek-absolute seek-input
- pixel-depth read-postage-stamp-image :> postage-data
- ] unless
-
- scan-line-offset seek-absolute seek-input
- image-height read-scan-line-table :> scan-offsets
-
- #! Read optional developer section
- directory-offset 0 =
- [ f ]
- [
- directory-offset seek-absolute seek-input
- read-developer-directory read-developer-areas
- ] if :> developer-areas
- ] unless
- ] ignore-errors
-
- #! Only 24-bit uncompressed BGR and 32-bit uncompressed BGRA are supported.
- #! Other formats would need to be converted to work within the image class.
- map-type 0 = [ bad-tga-unsupported ] unless
- image-type 2 = [ bad-tga-unsupported ] unless
- pixel-depth { 24 32 } member? [ bad-tga-unsupported ] unless
- pixel-order { 0 2 } member? [ bad-tga-unsupported ] unless
-
- #! Create image instance
- image new
- alpha-bits 0 = [ BGR ] [ BGRA ] if >>component-order
- { image-width image-height } >>dim
- pixel-order 0 = >>upside-down?
- image-data >>bitmap
- ubyte-components >>component-type ;
-
-M: tga-image stream>image
- drop [ [ read-tga ] throw-on-eof ] with-input-stream ;
-
-M: tga-image image>stream
- drop
- [
- component-order>> { BGRA BGRA } member? [ bad-tga-unsupported ] unless
- ] keep
-
- B{ 0 } write #! id-length
- B{ 0 } write #! map-type
- B{ 2 } write #! image-type
- B{ 0 0 0 0 0 } write #! color map first, length, entry size
- B{ 0 0 0 0 } write #! x-origin, y-origin
- {
- [ dim>> first 2 >le write ]
- [ dim>> second 2 >le write ]
- [ component-order>>
- {
- { BGR [ B{ 24 } write ] }
- { BGRA [ B{ 32 } write ] }
- } case
- ]
- [
- dup component-order>>
- {
- { BGR [ 0 ] }
- { BGRA [ 8 ] }
- } case swap
- upside-down?>> [ 0 ] [ 2 ] if 3 shift bitor
- 1 >le write
- ]
- [ bitmap>> write ]
- } cleave ;
-
+++ /dev/null
-Doug Coleman
+++ /dev/null
-TIFF image loader
+++ /dev/null
-! Copyright (C) 2009 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: images.testing ;
-IN: images.tiff.tests
-
-"vocab:images/testing/tiff/octagon.tiff" decode-test
-! "vocab:images/testing/tiff/elephants.tiff" decode-test
-"vocab:images/testing/tiff/noise.tiff" decode-test
-"vocab:images/testing/tiff/alpha.tiff" decode-test
-"vocab:images/testing/tiff/color_spectrum.tiff" decode-test
-"vocab:images/testing/tiff/rgb.tiff" decode-test
+++ /dev/null
-! Copyright (C) 2009 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs byte-arrays classes combinators
-compression.lzw endian fry grouping images io
-io.binary io.encodings.ascii io.encodings.binary
-io.encodings.string io.encodings.utf8 io.files kernel math
-math.bitwise math.order math.parser pack sequences
-strings math.vectors specialized-arrays locals
-images.loader io.streams.throwing ;
-FROM: alien.c-types => float ;
-SPECIALIZED-ARRAY: float
-IN: images.tiff
-
-SINGLETON: tiff-image
-
-TUPLE: loading-tiff endianness the-answer ifd-offset ifds ;
-
-: <loading-tiff> ( -- tiff )
- loading-tiff new V{ } clone >>ifds ;
-
-TUPLE: ifd count ifd-entries next
-processed-tags strips bitmap ;
-
-: <ifd> ( count ifd-entries next -- ifd )
- ifd new
- swap >>next
- swap >>ifd-entries
- swap >>count ;
-
-TUPLE: ifd-entry tag type count offset/value ;
-
-: <ifd-entry> ( tag type count offset/value -- ifd-entry )
- ifd-entry new
- swap >>offset/value
- swap >>count
- swap >>type
- swap >>tag ;
-
-SINGLETONS: photometric-interpretation
-photometric-interpretation-white-is-zero
-photometric-interpretation-black-is-zero
-photometric-interpretation-rgb
-photometric-interpretation-palette-color
-photometric-interpretation-transparency-mask
-photometric-interpretation-separated
-photometric-interpretation-ycbcr
-photometric-interpretation-cielab
-photometric-interpretation-icclab
-photometric-interpretation-itulab
-photometric-interpretation-logl
-photometric-interpretation-logluv ;
-
-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 ] }
- { 4 [ photometric-interpretation-transparency-mask ] }
- { 5 [ photometric-interpretation-separated ] }
- { 6 [ photometric-interpretation-ycbcr ] }
- { 8 [ photometric-interpretation-cielab ] }
- { 9 [ photometric-interpretation-icclab ] }
- { 10 [ photometric-interpretation-itulab ] }
- { 32844 [ photometric-interpretation-logl ] }
- { 32845 [ photometric-interpretation-logluv ] }
- [ bad-photometric-interpretation ]
- } case ;
-
-SINGLETONS: compression
-compression-none
-compression-CCITT-2
-compression-CCITT-3
-compression-CCITT-4
-compression-lzw
-compression-jpeg-old
-compression-jpeg-new
-compression-adobe-deflate
-compression-9
-compression-10
-compression-deflate
-compression-next
-compression-ccittrlew
-compression-pack-bits
-compression-thunderscan
-compression-it8ctpad
-compression-it8lw
-compression-it8mp
-compression-it8bl
-compression-pixarfilm
-compression-pixarlog
-compression-dcs
-compression-jbig
-compression-sgilog
-compression-sgilog24
-compression-jp2000 ;
-ERROR: bad-compression n ;
-: lookup-compression ( n -- compression )
- {
- { 1 [ compression-none ] }
- { 2 [ compression-CCITT-2 ] }
- { 3 [ compression-CCITT-3 ] }
- { 4 [ compression-CCITT-4 ] }
- { 5 [ compression-lzw ] }
- { 6 [ compression-jpeg-old ] }
- { 7 [ compression-jpeg-new ] }
- { 8 [ compression-adobe-deflate ] }
- { 9 [ compression-9 ] }
- { 10 [ compression-10 ] }
- { 32766 [ compression-next ] }
- { 32771 [ compression-ccittrlew ] }
- { 32773 [ compression-pack-bits ] }
- { 32809 [ compression-thunderscan ] }
- { 32895 [ compression-it8ctpad ] }
- { 32896 [ compression-it8lw ] }
- { 32897 [ compression-it8mp ] }
- { 32898 [ compression-it8bl ] }
- { 32908 [ compression-pixarfilm ] }
- { 32909 [ compression-pixarlog ] }
- { 32946 [ compression-deflate ] }
- { 32947 [ compression-dcs ] }
- { 34661 [ compression-jbig ] }
- { 34676 [ compression-sgilog ] }
- { 34677 [ compression-sgilog24 ] }
- { 34712 [ compression-jp2000 ] }
- [ 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-none
-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 )
- [
- {
- { 0 [ sample-format-none ] }
- { 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 subfile-type orientation
-software date-time photoshop exif-ifd sub-ifd inter-color-profile
-xmp iptc fill-order document-name page-number page-name
-x-position y-position host-computer copyright artist
-min-sample-value max-sample-value tiff-make tiff-model cell-width cell-length
-gray-response-unit gray-response-curve color-map threshholding
-image-description free-offsets free-byte-counts tile-width tile-length
-matteing data-type image-depth tile-depth
-ycbcr-subsampling gdal-metadata
-tile-offsets tile-byte-counts jpeg-qtables jpeg-dctables jpeg-actables
-ycbcr-positioning ycbcr-coefficients reference-black-white halftone-hints
-jpeg-interchange-format
-jpeg-interchange-format-length
-jpeg-restart-interval jpeg-tables
-t4-options clean-fax-data bad-fax-lines consecutive-bad-fax-lines
-sto-nits print-image-matching-info
-unhandled-ifd-entry ;
-
-SINGLETONS: jpeg-proc
-jpeg-proc-baseline
-jpeg-proc-lossless ;
-
-ERROR: bad-jpeg-proc n ;
-
-: lookup-jpeg-proc ( sequence -- object )
- {
- { 1 [ jpeg-proc-baseline ] }
- { 14 [ jpeg-proc-lossless ] }
- [ bad-jpeg-proc ]
- } case ;
-
-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 offset -- tiff )
- seek-absolute seek-input
- 2 read endian>
- dup [ read-ifd ] replicate
- 4 read endian>
- [ <ifd> push-ifd ] [ dup 0 = [ drop ] [ read-ifds ] if ] bi ;
-
-ERROR: no-tag class ;
-
-: find-tag* ( ifd class -- tag/class ? )
- swap processed-tags>> ?at ;
-
-: find-tag ( ifd class -- tag )
- find-tag* [ no-tag ] unless ;
-
-: tag? ( ifd class -- tag )
- swap processed-tags>> key? ;
-
-: 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 * ] }
- { 13 [ 4 * ] }
- [ 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 ] }
- { 13 [ endian> 32 >signed ] }
- [ 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 ] }
- { 255 [ subfile-type ] }
- { 256 [ image-width ] }
- { 257 [ image-length ] }
- { 258 [ bits-per-sample ] }
- { 259 [ lookup-compression compression ] }
- { 262 [ lookup-photometric-interpretation photometric-interpretation ] }
- { 263 [ threshholding ] }
- { 264 [ cell-width ] }
- { 265 [ cell-length ] }
- { 266 [ fill-order ] }
- { 269 [ ascii decode document-name ] }
- { 270 [ ascii decode image-description ] }
- { 271 [ ascii decode tiff-make ] }
- { 272 [ ascii decode tiff-model ] }
- { 273 [ strip-offsets ] }
- { 274 [ orientation ] }
- { 277 [ samples-per-pixel ] }
- { 278 [ rows-per-strip ] }
- { 279 [ strip-byte-counts ] }
- { 280 [ min-sample-value ] }
- { 281 [ max-sample-value ] }
- { 282 [ first x-resolution ] }
- { 283 [ first y-resolution ] }
- { 284 [ lookup-planar-configuration planar-configuration ] }
- { 285 [ page-name ] }
- { 286 [ x-position ] }
- { 287 [ y-position ] }
- { 288 [ free-offsets ] }
- { 289 [ free-byte-counts ] }
- { 290 [ gray-response-unit ] }
- { 291 [ gray-response-curve ] }
- { 292 [ t4-options ] }
- { 296 [ lookup-resolution-unit resolution-unit ] }
- { 297 [ page-number ] }
- { 305 [ ascii decode software ] }
- { 306 [ ascii decode date-time ] }
- { 315 [ ascii decode artist ] }
- { 316 [ ascii decode host-computer ] }
- { 317 [ lookup-predictor predictor ] }
- { 320 [ color-map ] }
- { 321 [ halftone-hints ] }
- { 322 [ tile-width ] }
- { 323 [ tile-length ] }
- { 324 [ tile-offsets ] }
- { 325 [ tile-byte-counts ] }
- { 326 [ bad-fax-lines ] }
- { 327 [ clean-fax-data ] }
- { 328 [ consecutive-bad-fax-lines ] }
- { 330 [ sub-ifd ] }
- { 338 [ lookup-extra-samples extra-samples ] }
- { 339 [ lookup-sample-format sample-format ] }
- { 347 [ jpeg-tables ] }
- { 512 [ lookup-jpeg-proc jpeg-proc ] }
- { 513 [ jpeg-interchange-format ] }
- { 514 [ jpeg-interchange-format-length ] }
- { 515 [ jpeg-restart-interval ] }
- { 519 [ jpeg-qtables ] }
- { 520 [ jpeg-dctables ] }
- { 521 [ jpeg-actables ] }
- { 529 [ ycbcr-coefficients ] }
- { 530 [ ycbcr-subsampling ] }
- { 531 [ ycbcr-positioning ] }
- { 532 [ reference-black-white ] }
- { 700 [ utf8 decode xmp ] }
- { 32995 [ matteing ] }
- { 32996 [ data-type ] }
- { 32997 [ image-depth ] }
- { 32998 [ tile-depth ] }
- { 33432 [ copyright ] }
- { 33723 [ iptc ] }
- { 34377 [ photoshop ] }
- { 34665 [ exif-ifd ] }
- { 34675 [ inter-color-profile ] }
- { 37439 [ sto-nits ] }
- { 42112 [ gdal-metadata ] }
- { 50341 [ print-image-matching-info ] }
- [ nip unhandled-ifd-entry swap ]
- } case ;
-
-: process-ifds ( loading-tiff -- loading-tiff )
- [
- [
- dup ifd-entries>>
- [ process-ifd-entry swap ] H{ } map>assoc >>processed-tags
- ] map
- ] change-ifds ;
-
-ERROR: unhandled-compression compression ;
-
-: (uncompress-strips) ( strips compression -- uncompressed-strips )
- {
- { compression-none [ ] }
- { compression-lzw [ [ tiff-lzw-uncompress ] map ] }
- [ unhandled-compression ]
- } case ;
-
-: uncompress-strips ( ifd -- ifd )
- dup '[
- _ compression find-tag (uncompress-strips)
- ] change-strips ;
-
-: strips>bitmap ( ifd -- ifd )
- dup strips>> concat >>bitmap ;
-
-: (strips-predictor) ( ifd -- ifd )
- [ ]
- [ image-width find-tag ]
- [ samples-per-pixel find-tag ] tri
- [ * ] keep
- '[
- _ group
- [ _ group unclip [ v+ ] accumulate swap suffix concat ] map
- B{ } concat-as
- ] change-bitmap ;
-
-: strips-predictor ( ifd -- ifd )
- dup predictor tag? [
- dup predictor find-tag
- {
- { predictor-none [ ] }
- { predictor-horizontal-differencing [ (strips-predictor) ] }
- [ bad-predictor ]
- } case
- ] when ;
-
-ERROR: unknown-component-order ifd ;
-
-: fix-bitmap-endianness ( ifd -- ifd )
- dup [ bitmap>> ] [ bits-per-sample find-tag ] bi
- {
- { { 32 32 32 32 } [ 4 seq>native-endianness ] }
- { { 32 32 32 } [ 4 seq>native-endianness ] }
- { { 16 16 16 16 } [ 2 seq>native-endianness ] }
- { { 16 16 16 } [ 2 seq>native-endianness ] }
- { { 8 8 8 8 } [ ] }
- { { 8 8 8 } [ ] }
- { 8 [ ] }
- [ unknown-component-order ]
- } case >>bitmap ;
-
-: ifd-component-order ( ifd -- component-order component-type )
- bits-per-sample find-tag {
- { { 32 32 32 32 } [ RGBA float-components ] }
- { { 32 32 32 } [ RGB float-components ] }
- { { 16 16 16 16 } [ RGBA ushort-components ] }
- { { 16 16 16 } [ RGB ushort-components ] }
- { { 8 8 8 8 } [ RGBA ubyte-components ] }
- { { 8 8 8 } [ RGB ubyte-components ] }
- { 8 [ LA ubyte-components ] }
- [ unknown-component-order ]
- } case ;
-
-: handle-alpha-data ( ifd -- ifd )
- dup extra-samples find-tag {
- { extra-samples-associated-alpha-data [ ] }
- { extra-samples-unspecified-alpha-data [ ] }
- { extra-samples-unassociated-alpha-data [ ] }
- [ bad-extra-samples ]
- } case ;
-
-: ifd>image ( ifd -- image )
- [ <image> ] dip {
- [ [ image-width find-tag ] [ image-length find-tag ] bi 2array >>dim ]
- [ ifd-component-order [ >>component-order ] [ >>component-type ] bi* ]
- [ bitmap>> >>bitmap ]
- } cleave ;
-
-: tiff>image ( image -- image )
- ifds>> [ ifd>image ] map first ;
-
-: with-tiff-endianness ( loading-tiff quot -- )
- [ dup endianness>> ] dip with-endianness ; inline
-
-: load-tiff-ifds ( -- loading-tiff )
- <loading-tiff>
- read-header [
- dup ifd-offset>> read-ifds
- process-ifds
- ] with-tiff-endianness ;
-
-: process-chunky-ifd ( ifd -- )
- read-strips
- uncompress-strips
- strips>bitmap
- fix-bitmap-endianness
- strips-predictor
- dup extra-samples tag? [ handle-alpha-data ] when
- drop ;
-
-: process-planar-ifd ( ifd -- )
- "planar ifd not supported" throw ;
-
-: dispatch-planar-configuration ( ifd planar-configuration -- )
- {
- { planar-configuration-chunky [ process-chunky-ifd ] }
- { planar-configuration-planar [ process-planar-ifd ] }
- } case ;
-
-: process-ifd ( ifd -- )
- dup planar-configuration find-tag* [
- dispatch-planar-configuration
- ] [
- drop "no planar configuration" throw
- ] if ;
-
-: process-tif-ifds ( loading-tiff -- )
- ifds>> [ process-ifd ] each ;
-
-: load-tiff ( -- loading-tiff )
- load-tiff-ifds dup
- 0 seek-absolute seek-input
- [ process-tif-ifds ] with-tiff-endianness ;
-
-! tiff files can store several images -- we just take the first for now
-M: tiff-image stream>image ( stream tiff-image -- image )
- drop [ [ load-tiff tiff>image ] throw-on-eof ] with-input-stream ;
-
-{ "tif" "tiff" } [ tiff-image register-image-class ] each
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: images.bitmap images.testing kernel ;
+IN: images.bitmap.tests
+
+! "vocab:images/testing/bmp/1bit.bmp" decode-test
+! "vocab:images/testing/bmp/rgb_4bit.bmp" decode-test
+
+"vocab:images/testing/bmp/rgb_8bit.bmp"
+[ decode-test ] [ bmp-image encode-test ] bi
+
+"vocab:images/testing/bmp/42red_24bit.bmp"
+[ decode-test ] [ bmp-image encode-test ] bi
--- /dev/null
+! Copyright (C) 2007, 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types arrays byte-arrays combinators
+compression.run-length fry grouping images images.loader
+images.normalization io io.binary io.encodings.8-bit.latin1
+io.encodings.string kernel math math.bitwise sequences
+specialized-arrays summary io.streams.throwing ;
+QUALIFIED-WITH: bitstreams b
+SPECIALIZED-ARRAYS: uint ushort ;
+IN: images.bitmap
+
+! http://www.fileformat.info/format/bmp/egff.htm
+! http://www.digicamsoft.com/bmp/bmp.html
+
+SINGLETON: bmp-image
+"bmp" bmp-image register-image-class
+
+: write2 ( n -- ) 2 >le write ;
+: write4 ( n -- ) 4 >le write ;
+
+ERROR: unknown-component-order bitmap ;
+ERROR: unknown-bitmap-header n ;
+
+: read2 ( -- n ) 2 read le> ;
+: read4 ( -- n ) 4 read le> ;
+
+TUPLE: loading-bitmap
+ file-header header
+ color-palette color-index bitfields ;
+
+TUPLE: file-header
+ { magic initial: "BM" }
+ { size }
+ { reserved1 initial: 0 }
+ { reserved2 initial: 0 }
+ { offset }
+ { header-length } ;
+
+TUPLE: v3-header
+ { width initial: 0 }
+ { height initial: 0 }
+ { planes initial: 0 }
+ { bit-count initial: 0 }
+ { compression initial: 0 }
+ { image-size initial: 0 }
+ { x-resolution initial: 0 }
+ { y-resolution initial: 0 }
+ { colors-used initial: 0 }
+ { colors-important initial: 0 } ;
+
+TUPLE: v4-header < v3-header
+ { red-mask initial: 0 }
+ { green-mask initial: 0 }
+ { blue-mask initial: 0 }
+ { alpha-mask initial: 0 }
+ { cs-type initial: 0 }
+ { end-points initial: 0 }
+ { gamma-red initial: 0 }
+ { gamma-green initial: 0 }
+ { gamma-blue initial: 0 } ;
+
+TUPLE: v5-header < v4-header
+ { intent initial: 0 }
+ { profile-data initial: 0 }
+ { profile-size initial: 0 }
+ { reserved3 initial: 0 } ;
+
+TUPLE: os2v1-header
+ { width initial: 0 }
+ { height initial: 0 }
+ { planes initial: 0 }
+ { bit-count initial: 0 } ;
+
+TUPLE: os2v2-header < os2v1-header
+ { compression initial: 0 }
+ { image-size initial: 0 }
+ { x-resolution initial: 0 }
+ { y-resolution initial: 0 }
+ { colors-used initial: 0 }
+ { colors-important initial: 0 }
+ { units initial: 0 }
+ { reserved initial: 0 }
+ { recording initial: 0 }
+ { rendering initial: 0 }
+ { size1 initial: 0 }
+ { size2 initial: 0 }
+ { color-encoding initial: 0 }
+ { identifier initial: 0 } ;
+
+UNION: v-header v3-header v4-header v5-header ;
+UNION: os2-header os2v1-header os2v2-header ;
+
+: parse-file-header ( -- file-header )
+ \ file-header new
+ 2 read latin1 decode >>magic
+ read4 >>size
+ read2 >>reserved1
+ read2 >>reserved2
+ read4 >>offset
+ read4 >>header-length ;
+
+: read-v3-header-data ( header -- header )
+ read4 >>width
+ read4 32 >signed >>height
+ read2 >>planes
+ read2 >>bit-count
+ read4 >>compression
+ read4 >>image-size
+ read4 >>x-resolution
+ read4 >>y-resolution
+ read4 >>colors-used
+ read4 >>colors-important ;
+
+: read-v3-header ( -- header )
+ \ v3-header new
+ read-v3-header-data ;
+
+: read-v4-header-data ( header -- header )
+ read4 >>red-mask
+ read4 >>green-mask
+ read4 >>blue-mask
+ read4 >>alpha-mask
+ read4 >>cs-type
+ read4 read4 read4 3array >>end-points
+ read4 >>gamma-red
+ read4 >>gamma-green
+ read4 >>gamma-blue ;
+
+: read-v4-header ( -- v4-header )
+ \ v4-header new
+ read-v3-header-data
+ read-v4-header-data ;
+
+: read-v5-header-data ( v5-header -- v5-header )
+ read4 >>intent
+ read4 >>profile-data
+ read4 >>profile-size
+ read4 >>reserved3 ;
+
+: read-v5-header ( -- loading-bitmap )
+ \ v5-header new
+ read-v3-header-data
+ read-v4-header-data
+ read-v5-header-data ;
+
+: read-os2v1-header ( -- os2v1-header )
+ \ os2v1-header new
+ read2 >>width
+ read2 16 >signed >>height
+ read2 >>planes
+ read2 >>bit-count ;
+
+: read-os2v2-header-data ( os2v2-header -- os2v2-header )
+ read4 >>width
+ read4 32 >signed >>height
+ read2 >>planes
+ read2 >>bit-count
+ read4 >>compression
+ read4 >>image-size
+ read4 >>x-resolution
+ read4 >>y-resolution
+ read4 >>colors-used
+ read4 >>colors-important
+ read2 >>units
+ read2 >>reserved
+ read2 >>recording
+ read2 >>rendering
+ read4 >>size1
+ read4 >>size2
+ read4 >>color-encoding
+ read4 >>identifier ;
+
+: read-os2v2-header ( -- os2v2-header )
+ \ os2v2-header new
+ read-os2v2-header-data ;
+
+: parse-header ( n -- header )
+ {
+ { 12 [ read-os2v1-header ] }
+ { 64 [ read-os2v2-header ] }
+ { 40 [ read-v3-header ] }
+ { 108 [ read-v4-header ] }
+ { 124 [ read-v5-header ] }
+ [ unknown-bitmap-header ]
+ } case ;
+
+: color-index-length ( header -- n )
+ {
+ [ width>> ]
+ [ planes>> * ]
+ [ bit-count>> * 31 + 32 /i 4 * ]
+ [ height>> abs * ]
+ } cleave ;
+
+: color-palette-length ( loading-bitmap -- n )
+ file-header>>
+ [ offset>> 14 - ] [ header-length>> ] bi - ;
+
+: parse-color-palette ( loading-bitmap -- loading-bitmap )
+ dup color-palette-length read >>color-palette ;
+
+GENERIC: parse-color-data* ( loading-bitmap header -- loading-bitmap )
+
+: parse-color-data ( loading-bitmap -- loading-bitmap )
+ dup header>> parse-color-data* ;
+
+M: os2v1-header parse-color-data* ( loading-bitmap header -- loading-bitmap )
+ color-index-length read >>color-index ;
+
+M: object parse-color-data* ( loading-bitmap header -- loading-bitmap )
+ dup image-size>> [ 0 ] unless* dup 0 >
+ [ nip ] [ drop color-index-length ] if read >>color-index ;
+
+: alpha-used? ( loading-bitmap -- ? )
+ color-index>> 4 <sliced-groups> [ fourth 0 = ] all? not ;
+
+GENERIC: bitmap>component-order* ( loading-bitmap header -- object )
+
+: bitmap>component-order ( loading-bitmap -- object )
+ dup header>> bitmap>component-order* ;
+
+: simple-bitmap>component-order ( loading-bitamp -- object )
+ header>> bit-count>> {
+ { 32 [ BGRX ] }
+ { 24 [ BGR ] }
+ { 16 [ BGR ] }
+ { 8 [ BGR ] }
+ { 4 [ BGR ] }
+ { 1 [ BGR ] }
+ [ unknown-component-order ]
+ } case ;
+
+: advanced-bitmap>component-order ( loading-bitmap -- object )
+ [ ] [ header>> bit-count>> ] [ alpha-used? ] tri 2array {
+ { { 32 t } [ drop BGRA ] }
+ { { 32 f } [ drop BGRX ] }
+ [ drop simple-bitmap>component-order ]
+ } case ;
+
+: color-lookup3 ( loading-bitmap -- seq )
+ [ color-index>> >array ]
+ [ color-palette>> 3 <sliced-groups> ] bi
+ '[ _ nth ] map concat ;
+
+: color-lookup4 ( loading-bitmap -- seq )
+ [ color-index>> >array ]
+ [ color-palette>> 4 <sliced-groups> [ 3 head-slice ] map ] bi
+ '[ _ nth ] map concat ;
+
+! os2v1 is 3bytes each, all others are 3 + 1 unused
+: color-lookup ( loading-bitmap -- seq )
+ dup file-header>> header-length>> {
+ { 12 [ color-lookup3 ] }
+ { 64 [ color-lookup4 ] }
+ { 40 [ color-lookup4 ] }
+ { 108 [ color-lookup4 ] }
+ { 124 [ color-lookup4 ] }
+ } case ;
+
+M: os2v1-header bitmap>component-order* drop simple-bitmap>component-order ;
+M: os2v2-header bitmap>component-order* drop simple-bitmap>component-order ;
+M: v3-header bitmap>component-order* drop simple-bitmap>component-order ;
+M: v4-header bitmap>component-order* drop advanced-bitmap>component-order ;
+M: v5-header bitmap>component-order* drop advanced-bitmap>component-order ;
+
+: uncompress-bitfield ( seq masks -- bytes' )
+ '[
+ _ [
+ [ bitand ] [ bit-count ] [ log2 ] tri - shift
+ ] with map
+ ] { } map-as B{ } concat-as ;
+
+ERROR: bmp-not-supported n ;
+
+: bitmap>bytes ( loading-bitmap -- byte-array )
+ dup header>> bit-count>>
+ {
+ { 32 [ color-index>> ] }
+ { 24 [ color-index>> ] }
+ { 16 [
+ [
+ ! ushort-array-cast
+ 2 group [ le> ] map
+ ! 5 6 5
+ ! { HEX: f800 HEX: 7e0 HEX: 1f } uncompress-bitfield
+ ! 5 5 5
+ { HEX: 7c00 HEX: 3e0 HEX: 1f } uncompress-bitfield
+ ] change-color-index
+ color-index>>
+ ] }
+ { 8 [ color-lookup ] }
+ { 4 [ [ 4 b:byte-array-n>seq ] change-color-index color-lookup ] }
+ { 1 [ [ 1 b:byte-array-n>seq ] change-color-index color-lookup ] }
+ [ bmp-not-supported ]
+ } case >byte-array ;
+
+: set-bitfield-widths ( loading-bitmap -- loading-bitmap' )
+ dup header>> bit-count>> {
+ { 16 [ dup color-palette>> 4 group [ le> ] map ] }
+ { 32 [ { HEX: ff0000 HEX: ff00 HEX: ff } ] }
+ } case reverse >>bitfields ;
+
+ERROR: unsupported-bitfield-widths n ;
+
+M: unsupported-bitfield-widths summary
+ drop "Bitmaps only support bitfield compression in 16/32bit images" ;
+
+: uncompress-bitfield-widths ( loading-bitmap -- loading-bitmap' )
+ set-bitfield-widths
+ dup header>> bit-count>> {
+ { 16 [
+ dup bitfields>> '[
+ ushort-array-cast _ uncompress-bitfield
+ ] change-color-index
+ ] }
+ { 32 [ ] }
+ [ unsupported-bitfield-widths ]
+ } case ;
+
+ERROR: unsupported-bitmap-compression compression ;
+
+GENERIC: uncompress-bitmap* ( loading-bitmap header -- loading-bitmap )
+
+: uncompress-bitmap ( loading-bitmap -- loading-bitmap )
+ dup header>> uncompress-bitmap* ;
+
+M: os2-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' )
+ drop ;
+
+: do-run-length-uncompress ( loading-bitmap word -- loading-bitmap )
+ dupd '[
+ _ header>> [ width>> ] [ height>> ] bi
+ _ execute
+ ] change-color-index ; inline
+
+M: v-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' )
+ compression>> {
+ { f [ ] }
+ { 0 [ ] }
+ { 1 [ \ run-length-uncompress-bitmap8 do-run-length-uncompress ] }
+ { 2 [ \ run-length-uncompress-bitmap4 do-run-length-uncompress ] }
+ { 3 [ uncompress-bitfield-widths ] }
+ { 4 [ "jpeg" unsupported-bitmap-compression ] }
+ { 5 [ "png" unsupported-bitmap-compression ] }
+ } case ;
+
+ERROR: unsupported-bitmap-file magic ;
+
+: load-bitmap ( stream -- loading-bitmap )
+ [
+ [
+ \ loading-bitmap new
+ parse-file-header [ >>file-header ] [ ] bi magic>> {
+ { "BM" [
+ dup file-header>> header-length>> parse-header >>header
+ parse-color-palette
+ parse-color-data
+ ] }
+ ! { "BA" [ parse-os2-bitmap-array ] }
+ ! { "CI" [ parse-os2-color-icon ] }
+ ! { "CP" [ parse-os2-color-pointer ] }
+ ! { "IC" [ parse-os2-icon ] }
+ ! { "PT" [ parse-os2-pointer ] }
+ [ unsupported-bitmap-file ]
+ } case
+ ] throw-on-eof
+ ] with-input-stream ;
+
+: loading-bitmap>bytes ( loading-bitmap -- byte-array )
+ uncompress-bitmap bitmap>bytes ;
+
+M: bmp-image stream>image ( stream bmp-image -- bitmap )
+ drop load-bitmap
+ [ image new ] dip
+ {
+ [ loading-bitmap>bytes >>bitmap ]
+ [ header>> [ width>> ] [ height>> abs ] bi 2array >>dim ]
+ [ header>> height>> 0 < not >>upside-down? ]
+ [ bitmap>component-order >>component-order ubyte-components >>component-type ]
+ } cleave ;
+
+: output-width-and-height ( image -- )
+ [ dim>> first write4 ]
+ [
+ [ dim>> second ] [ upside-down?>> ] bi
+ [ neg ] unless write4
+ ] bi ;
+
+: output-bmp ( image -- )
+ B{ CHAR: B CHAR: M } write
+ [
+ bitmap>> length 14 + 40 + write4
+ 0 write4
+ 54 write4
+ 40 write4
+ ] [
+ {
+ [ output-width-and-height ]
+
+ ! planes
+ [ drop 1 write2 ]
+
+ ! bit-count
+ [ drop 24 write2 ]
+
+ ! compression
+ [ drop 0 write4 ]
+
+ ! image-size
+ [ bitmap>> length write4 ]
+
+ ! x-pels
+ [ drop 0 write4 ]
+
+ ! y-pels
+ [ drop 0 write4 ]
+
+ ! color-used
+ [ drop 0 write4 ]
+
+ ! color-important
+ [ drop 0 write4 ]
+
+ ! color-palette
+ [ bitmap>> write ]
+ } cleave
+ ] bi ;
+
+M: bmp-image image>stream
+ drop BGR reorder-components output-bmp ;
+
--- /dev/null
+Windows BMP image loader
--- /dev/null
+! Copyright (C) 2009 Marc Fauconneau.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays byte-arrays combinators
+compression.huffman fry grouping images images.loader
+images.processing io io.binary io.encodings.binary
+io.streams.byte-array io.streams.limited io.streams.throwing
+kernel locals math math.bitwise math.blas.matrices
+math.blas.vectors math.constants math.functions math.matrices
+math.order math.vectors memoize namespaces sequences
+sequences.deep ;
+QUALIFIED-WITH: bitstreams bs
+IN: images.jpeg
+
+SINGLETON: jpeg-image
+
+TUPLE: loading-jpeg < image
+ { headers }
+ { bitstream }
+ { color-info initial: { f f f f } }
+ { quant-tables initial: { f f } }
+ { huff-tables initial: { f f f f } }
+ { components } ;
+
+"jpg" jpeg-image register-image-class
+"jpeg" jpeg-image register-image-class
+
+<PRIVATE
+
+: <loading-jpeg> ( headers bitstream -- image )
+ loading-jpeg new swap >>bitstream swap >>headers ;
+
+SINGLETONS: SOF DHT DAC RST SOI EOI SOS DQT DNL DRI DHP EXP
+APP JPG COM TEM RES ;
+
+! ISO/IEC 10918-1 Table B.1
+:: >marker ( byte -- marker )
+ byte
+ {
+ { [ dup HEX: CC = ] [ { DAC } ] }
+ { [ dup HEX: C4 = ] [ { DHT } ] }
+ { [ dup HEX: C9 = ] [ { JPG } ] }
+ { [ dup -4 shift HEX: C = ] [ SOF byte 4 bits 2array ] }
+
+ { [ dup HEX: D8 = ] [ { SOI } ] }
+ { [ dup HEX: D9 = ] [ { EOI } ] }
+ { [ dup HEX: DA = ] [ { SOS } ] }
+ { [ dup HEX: DB = ] [ { DQT } ] }
+ { [ dup HEX: DC = ] [ { DNL } ] }
+ { [ dup HEX: DD = ] [ { DRI } ] }
+ { [ dup HEX: DE = ] [ { DHP } ] }
+ { [ dup HEX: DF = ] [ { EXP } ] }
+ { [ dup -4 shift HEX: D = ] [ RST byte 4 bits 2array ] }
+
+ { [ dup -4 shift HEX: E = ] [ APP byte 4 bits 2array ] }
+ { [ dup HEX: FE = ] [ { COM } ] }
+ { [ dup -4 shift HEX: F = ] [ JPG byte 4 bits 2array ] }
+
+ { [ dup HEX: 01 = ] [ { TEM } ] }
+ [ { RES } ]
+ }
+ cond nip ;
+
+TUPLE: jpeg-chunk length type data ;
+
+: <jpeg-chunk> ( type length data -- jpeg-chunk )
+ jpeg-chunk new
+ swap >>data
+ swap >>length
+ swap >>type ;
+
+TUPLE: jpeg-color-info
+ h v quant-table dc-huff-table ac-huff-table { diff initial: 0 } id ;
+
+: <jpeg-color-info> ( h v quant-table -- jpeg-color-info )
+ jpeg-color-info new
+ swap >>quant-table
+ swap >>v
+ swap >>h ;
+
+: jpeg> ( -- jpeg-image ) jpeg-image get ;
+
+: apply-diff ( dc color -- dc' )
+ [ diff>> + dup ] [ diff<< ] bi ;
+
+: fetch-tables ( component -- )
+ [ [ jpeg> quant-tables>> nth ] change-quant-table drop ]
+ [ [ jpeg> huff-tables>> nth ] change-dc-huff-table drop ]
+ [ [ 2 + jpeg> huff-tables>> nth ] change-ac-huff-table drop ] tri ;
+
+: read4/4 ( -- a b ) read1 16 /mod ;
+
+! headers
+
+: decode-frame ( header -- )
+ data>>
+ binary
+ [
+ read1 8 assert=
+ 2 read be>
+ 2 read be>
+ swap 2array jpeg> dim<<
+ read1
+ [
+ read1 read4/4 read1 <jpeg-color-info>
+ swap [ >>id ] keep jpeg> color-info>> set-nth
+ ] times
+ ] with-byte-reader ;
+
+: decode-quant-table ( chunk -- )
+ dup data>>
+ binary
+ [
+ length>>
+ 2 - 65 /
+ [
+ read4/4 [ 0 assert= ] dip
+ 64 read
+ swap jpeg> quant-tables>> set-nth
+ ] times
+ ] with-byte-reader ;
+
+: decode-huff-table ( chunk -- )
+ data>> [ binary <byte-reader> ] [ length ] bi limit-stream [
+ [ input-stream get stream>> [ count>> ] [ limit>> ] bi < ]
+ [
+ read4/4 swap 2 * +
+ 16 read
+ dup [ ] [ + ] map-reduce read
+ binary [ [ read [ B{ } ] unless* ] { } map-as ] with-byte-reader
+ swap jpeg> huff-tables>> set-nth
+ ] while
+ ] stream-throw-on-eof ;
+
+: decode-scan ( chunk -- )
+ data>>
+ binary
+ [
+ read1 iota
+ [ drop
+ read1 jpeg> color-info>> nth clone
+ read1 16 /mod [ >>dc-huff-table ] [ >>ac-huff-table ] bi*
+ ] map jpeg> components<<
+ read1 0 assert=
+ read1 63 assert=
+ read1 16 /mod [ 0 assert= ] bi@
+ ] with-byte-reader ;
+
+: singleton-first ( seq -- elt )
+ [ length 1 assert= ] [ first ] bi ;
+
+ERROR: not-a-baseline-jpeg-image ;
+
+: baseline-parse ( -- )
+ jpeg> headers>> [ type>> { SOF 0 } = ] any? [ not-a-baseline-jpeg-image ] unless
+ jpeg> headers>>
+ {
+ [ [ type>> { SOF 0 } = ] filter singleton-first decode-frame ]
+ [ [ type>> { DQT } = ] filter [ decode-quant-table ] each ]
+ [ [ type>> { DHT } = ] filter [ decode-huff-table ] each ]
+ [ [ type>> { SOS } = ] filter singleton-first decode-scan ]
+ } cleave ;
+
+: parse-marker ( -- marker )
+ read1 HEX: FF assert=
+ read1 >marker ;
+
+: parse-headers ( -- chunks )
+ [ parse-marker dup { SOS } = not ]
+ [
+ 2 read be>
+ dup 2 - read <jpeg-chunk>
+ ] [ produce ] keep dip swap suffix ;
+
+MEMO: zig-zag ( -- zz )
+ {
+ { 0 1 5 6 14 15 27 28 }
+ { 2 4 7 13 16 26 29 42 }
+ { 3 8 12 17 25 30 41 43 }
+ { 9 11 18 24 31 40 44 53 }
+ { 10 19 23 32 39 45 52 54 }
+ { 20 22 33 38 46 51 55 60 }
+ { 21 34 37 47 50 56 59 61 }
+ { 35 36 48 49 57 58 62 63 }
+ } flatten ;
+
+MEMO: yuv>bgr-matrix ( -- m )
+ {
+ { 1 2.03211 0 }
+ { 1 -0.39465 -0.58060 }
+ { 1 0 1.13983 }
+ } ;
+
+: wave ( x u -- n ) swap 2 * 1 + * pi * 16 / cos ;
+
+:: dct-vect ( u v -- basis )
+ { 8 8 } coord-matrix [ { u v } [ wave ] 2map product ] map^2
+ 1 u v [ 0 = [ 2 sqrt / ] when ] bi@ 4 / m*n ;
+
+MEMO: dct-matrix ( -- m ) 64 iota [ 8 /mod dct-vect flatten ] map ;
+
+: mb-dim ( component -- dim ) [ h>> ] [ v>> ] bi 2array ;
+
+! : blocks ( component -- seq )
+! mb-dim ! coord-matrix flip concat [ [ { 2 2 } v* ] [ v+ ] bi* ] with map ;
+
+: all-macroblocks ( quot: ( mb -- ) -- )
+ [
+ jpeg>
+ [ dim>> 8 v/n ]
+ [ color-info>> sift { 0 0 } [ mb-dim vmax ] reduce v/ ] bi
+ [ ceiling ] map
+ coord-matrix flip concat
+ ]
+ [ each ] bi* ; inline
+
+: reverse-zigzag ( b -- b' ) zig-zag swap [ nth ] curry map ;
+
+: idct-factor ( b -- b' ) dct-matrix v.m ;
+
+MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
+: V.M ( x A -- x.A ) Mtranspose swap M.V ;
+: idct-blas ( b -- b' ) >float-blas-vector dct-matrix-blas V.M ;
+
+: idct ( b -- b' ) idct-factor ;
+
+:: draw-block ( block x,y color-id jpeg-image -- )
+ block dup length>> sqrt >fixnum group flip
+ dup matrix-dim coord-matrix flip
+ [
+ [ '[ _ [ second ] [ first ] bi ] dip nth nth ]
+ [ x,y v+ color-id jpeg-image draw-color ] bi
+ ] with each^2 ;
+
+: sign-extend ( bits v -- v' )
+ swap [ ] [ 1 - 2^ < ] 2bi
+ [ -1 swap shift 1 + + ] [ drop ] if ;
+
+: read1-jpeg-dc ( decoder -- dc )
+ [ read1-huff dup ] [ bs>> bs:read ] bi sign-extend ;
+
+: read1-jpeg-ac ( decoder -- run/ac )
+ [ read1-huff 16 /mod dup ] [ bs>> bs:read ] bi sign-extend 2array ;
+
+:: decode-block ( color -- pixels )
+ color dc-huff-table>> read1-jpeg-dc color apply-diff
+ 64 0 <array> :> coefs
+ 0 coefs set-nth
+ 0 :> k!
+ [
+ color ac-huff-table>> read1-jpeg-ac
+ [ first 1 + k + k! ] [ second k coefs set-nth ] [ ] tri
+ { 0 0 } = not
+ k 63 < and
+ ] loop
+ coefs color quant-table>> v*
+ reverse-zigzag idct ;
+
+:: draw-macroblock-yuv420 ( mb blocks -- )
+ mb { 16 16 } v* :> pos
+ 0 blocks nth pos { 0 0 } v+ 0 jpeg> draw-block
+ 1 blocks nth pos { 8 0 } v+ 0 jpeg> draw-block
+ 2 blocks nth pos { 0 8 } v+ 0 jpeg> draw-block
+ 3 blocks nth pos { 8 8 } v+ 0 jpeg> draw-block
+ 4 blocks nth 8 group 2 matrix-zoom concat pos 1 jpeg> draw-block
+ 5 blocks nth 8 group 2 matrix-zoom concat pos 2 jpeg> draw-block ;
+
+:: draw-macroblock-yuv444 ( mb blocks -- )
+ mb { 8 8 } v* :> pos
+ 3 iota [ [ blocks nth pos ] [ jpeg> draw-block ] bi ] each ;
+
+:: draw-macroblock-y ( mb blocks -- )
+ mb { 8 8 } v* :> pos
+ 0 blocks nth pos 0 jpeg> draw-block
+ 64 0 <array> pos 1 jpeg> draw-block
+ 64 0 <array> pos 2 jpeg> draw-block ;
+
+ ! %fixme: color hack
+ ! color h>> 2 =
+ ! [ 8 group 2 matrix-zoom concat ] unless
+ ! pos { 8 8 } v* color jpeg> draw-block ;
+
+: decode-macroblock ( -- blocks )
+ jpeg> components>>
+ [
+ [ mb-dim first2 * ]
+ [ [ decode-block ] curry replicate ] bi
+ ] map concat ;
+
+: cleanup-bitstream ( bytes -- bytes' )
+ binary [
+ [
+ { HEX: FF } read-until
+ read1 [ HEX: 00 = and ] keep swap
+ ]
+ [ drop ] produce
+ swap >marker { EOI } assert=
+ swap suffix
+ { HEX: FF } join
+ ] with-byte-reader ;
+
+: setup-bitmap ( image -- )
+ dup dim>> 16 v/n [ ceiling ] map 16 v*n >>dim
+ BGR >>component-order
+ ubyte-components >>component-type
+ f >>upside-down?
+ dup dim>> first2 * 3 * 0 <array> >>bitmap
+ drop ;
+
+ERROR: unsupported-colorspace ;
+SINGLETONS: YUV420 YUV444 Y MAGIC! ;
+
+:: detect-colorspace ( jpeg-image -- csp )
+ jpeg-image color-info>> sift :> colors
+ MAGIC!
+ colors length 1 = [ drop Y ] when
+ colors length 3 =
+ [
+ colors [ mb-dim { 1 1 } = ] all?
+ [ drop YUV444 ] when
+
+ colors unclip
+ [ [ mb-dim { 1 1 } = ] all? ]
+ [ mb-dim { 2 2 } = ] bi* and
+ [ drop YUV420 ] when
+ ] when ;
+
+! this eats ~50% cpu time
+: draw-macroblocks ( mbs -- )
+ jpeg> detect-colorspace
+ {
+ { YUV420 [ [ first2 draw-macroblock-yuv420 ] each ] }
+ { YUV444 [ [ first2 draw-macroblock-yuv444 ] each ] }
+ { Y [ [ first2 draw-macroblock-y ] each ] }
+ [ unsupported-colorspace ]
+ } case ;
+
+! this eats ~25% cpu time
+: color-transform ( yuv -- rgb )
+ { 128 0 0 } v+ yuv>bgr-matrix swap m.v
+ [ 0 max 255 min >fixnum ] map ;
+
+: baseline-decompress ( -- )
+ jpeg> bitstream>> cleanup-bitstream { 255 255 255 255 } append
+ >byte-array bs:<msb0-bit-reader> jpeg> bitstream<<
+ jpeg>
+ [ bitstream>> ]
+ [ [ [ <huffman-decoder> ] with map ] change-huff-tables drop ] bi
+ jpeg> components>> [ fetch-tables ] each
+ [ decode-macroblock 2array ] collector
+ [ all-macroblocks ] dip
+ jpeg> setup-bitmap draw-macroblocks
+ jpeg> bitmap>> 3 <groups> [ color-transform ] map! drop
+ jpeg> [ >byte-array ] change-bitmap drop ;
+
+ERROR: not-a-jpeg-image ;
+
+: loading-jpeg>image ( loading-jpeg -- image )
+ dup jpeg-image [
+ baseline-parse
+ baseline-decompress
+ ] with-variable ;
+
+: load-jpeg ( stream -- loading-jpeg )
+ [
+ parse-marker { SOI } = [ not-a-jpeg-image ] unless
+ parse-headers
+ contents <loading-jpeg>
+ ] with-input-stream ;
+
+PRIVATE>
+
+M: jpeg-image stream>image ( stream jpeg-image -- bitmap )
+ drop load-jpeg loading-jpeg>image ;
--- /dev/null
+Erik Charlebois
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: images.testing ;
+IN: images.pbm.tests
+
+"vocab:images/testing/pbm/test.binary.pbm" decode-test
+"vocab:images/testing/pbm/test.ascii.pbm" decode-test
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays ascii bit-arrays byte-arrays combinators
+continuations grouping images images.loader io io.encodings.ascii
+io.encodings.string kernel locals make math math.functions math.parser
+sequences io.streams.throwing ;
+IN: images.pbm
+
+SINGLETON: pbm-image
+"pbm" pbm-image register-image-class
+
+<PRIVATE
+: read-token ( -- token )
+ [
+ read1 dup blank?
+ [ t ]
+ [
+ dup CHAR: # =
+ [ "\n" read-until 2drop t ]
+ [ f ] if
+ ] if
+ ] [ drop ] while
+ " \n\r\t" read-until drop swap
+ prefix ascii decode ;
+
+: read-number ( -- number )
+ read-token string>number ;
+
+: read-ascii-bits ( -- )
+ read1 {
+ { CHAR: 1 [ 0 , read-ascii-bits ] }
+ { CHAR: 0 [ 255 , read-ascii-bits ] }
+ { f [ ] }
+ [ drop read-ascii-bits ]
+ } case ;
+
+:: read-binary-bits ( width height -- )
+ width 8 align 8 / height * read
+ width 8 align 8 / <groups> [| row |
+ width iota [| n |
+ n 8 / floor row nth
+ n 8 mod 7 swap - bit?
+ [ 0 ] [ 255 ] if ,
+ ] each
+ ] each ;
+
+:: write-binary-bits ( bitmap width -- )
+ bitmap width <groups> [
+ width 8 align 255 pad-tail
+ 8 <groups> [
+ [ 255 = [ f ] [ t ] if ] { } map-as
+ >bit-array reverse bit-array>integer
+ 1array >byte-array write
+ ] each
+ ] each ;
+
+:: read-pbm ( -- image )
+ read-token :> type
+ read-number :> width
+ read-number :> height
+
+ type {
+ { "P1" [ [ [ read-ascii-bits ] ignore-errors ] B{ } make ] }
+ { "P4" [ [ width height read-binary-bits ] B{ } make ] }
+ } case :> data
+
+ image new
+ L >>component-order
+ { width height } >>dim
+ f >>upside-down?
+ data >>bitmap
+ ubyte-components >>component-type ;
+PRIVATE>
+
+M: pbm-image stream>image
+ drop [ [ read-pbm ] throw-on-eof ] with-input-stream ;
+
+M: pbm-image image>stream
+ drop {
+ [ drop "P4\n" ascii encode write ]
+ [ dim>> first number>string " " append ascii encode write ]
+ [ dim>> second number>string "\n" append ascii encode write ]
+ [ [ bitmap>> ] [ dim>> first ] bi write-binary-bits ]
+ } cleave ;
--- /dev/null
+Image loading for PBM image files.
--- /dev/null
+Erik Charlebois
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: images.testing ;
+IN: images.pgm.tests
+
+"vocab:images/testing/pgm/radial.binary.pgm" decode-test
+"vocab:images/testing/pgm/radial.ascii.pgm" decode-test
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types ascii combinators images images.loader
+io io.encodings.ascii io.encodings.string kernel locals make math
+math.parser sequences specialized-arrays io.streams.throwing ;
+SPECIALIZED-ARRAY: ushort
+IN: images.pgm
+
+SINGLETON: pgm-image
+"pgm" pgm-image register-image-class
+
+: read-token ( -- token )
+ [ read1 dup blank?
+ [ t ]
+ [ dup CHAR: # =
+ [ "\n" read-until 2drop t ]
+ [ f ] if
+ ] if
+ ] [ drop ] while
+ " \n\r\t" read-until drop swap
+ prefix ascii decode ;
+
+: read-number ( -- number )
+ read-token string>number ;
+
+:: read-numbers ( n lim -- )
+ n lim = [
+ read-number ,
+ n 1 + lim read-numbers
+ ] unless ;
+
+:: read-pgm ( -- image )
+ read-token :> type
+ read-number :> width
+ read-number :> height
+ read-number :> max
+ width height * :> npixels
+ max 256 >= :> wide
+
+ type {
+ { "P2" [ [ 0 npixels read-numbers ] wide [ ushort-array{ } ] [ B{ } ] if make ] }
+ { "P5" [ wide [ 2 ] [ 1 ] if npixels * read ] }
+ } case :> data
+
+ image new
+ L >>component-order
+ { width height } >>dim
+ f >>upside-down?
+ data >>bitmap
+ wide [ ushort-components ] [ ubyte-components ] if >>component-type ;
+
+M: pgm-image stream>image
+ drop [ [ read-pgm ] throw-on-eof ] with-input-stream ;
+
+M: pgm-image image>stream
+ drop {
+ [ drop "P5\n" ascii encode write ]
+ [ dim>> first number>string " " append ascii encode write ]
+ [ dim>> second number>string "\n" append ascii encode write ]
+ [ component-type>> ubyte-components = [ "255\n" ] [ "65535\n" ] if ascii encode write ]
+ [ bitmap>> write ]
+ } cleave ;
--- /dev/null
+Image loading for PGM image files.
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2009 Doug Coleman, Keith Lazuka
+! See http://factorcode.org/license.txt for BSD license.
+USING: images.testing io.directories ;
+IN: images.png.tests
+
+! Test files from PngSuite (http://www.libpng.org/pub/png/pngsuite.html)
+
+! The subset of the suite that should work given the current implementation.
+"vocab:images/testing/png" [
+ "basi0g01.png" decode-test
+ "basi0g02.png" decode-test
+ "basi0g04.png" decode-test
+ "basi0g08.png" decode-test
+ "basi0g16.png" decode-test
+ "basi2c08.png" decode-test
+ "basi3p01.png" decode-test
+ "basi3p02.png" decode-test
+ "basi3p04.png" decode-test
+ "basi3p08.png" decode-test
+ "basn0g01.png" decode-test
+ "basn0g02.png" decode-test
+ "basn0g04.png" decode-test
+ "basn0g08.png" decode-test
+ "basn0g16.png" decode-test
+ "basn2c08.png" decode-test
+ "basn3p01.png" decode-test
+ "basn3p02.png" decode-test
+ "basn3p04.png" decode-test
+ "basn3p08.png" decode-test
+ "basn6a08.png" decode-test
+ "f00n2c08.png" decode-test
+ "f01n2c08.png" decode-test
+ "f02n2c08.png" decode-test
+ "f03n2c08.png" decode-test
+ "f04n2c08.png" decode-test
+ "s01i3p01.png" decode-test
+ "s01n3p01.png" decode-test
+ "s02i3p01.png" decode-test
+ "s02n3p01.png" decode-test
+ "s03i3p01.png" decode-test
+ "s03n3p01.png" decode-test
+ "s04i3p01.png" decode-test
+ "s04n3p01.png" decode-test
+ "s05i3p02.png" decode-test
+ "s05n3p02.png" decode-test
+ "s06i3p02.png" decode-test
+ "s06n3p02.png" decode-test
+ "s07i3p02.png" decode-test
+ "s07n3p02.png" decode-test
+ "s08i3p02.png" decode-test
+ "s08n3p02.png" decode-test
+ "s09i3p02.png" decode-test
+ "s32n3p04.png" decode-test
+ "s32i3p04.png" decode-test
+ "s33n3p04.png" decode-test
+ "s33i3p04.png" decode-test
+ "s34n3p04.png" decode-test
+ "s34i3p04.png" decode-test
+ "s35n3p04.png" decode-test
+ "s35i3p04.png" decode-test
+ "s36n3p04.png" decode-test
+ "s36i3p04.png" decode-test
+ "s37n3p04.png" decode-test
+ "s37i3p04.png" decode-test
+ "s38n3p04.png" decode-test
+ "s38i3p04.png" decode-test
+ "s39n3p04.png" decode-test
+ "s39i3p04.png" decode-test
+ "s40n3p04.png" decode-test
+ "s40i3p04.png" decode-test
+ "s07n3p02.png" decode-test
+ "z00n2c08.png" decode-test
+ "z03n2c08.png" decode-test
+ "z06n2c08.png" decode-test
+ "z09n2c08.png" decode-test
+] with-directory
+
+! The current PNG decoder implementation is very limited,
+! so the entire test suite is not currently enabled.
+! "vocab:images/testing/png/suite" [
+! "basi0g01.png" decode-test
+! "basi0g02.png" decode-test
+! "basi0g04.png" decode-test
+! "basi0g08.png" decode-test
+! "basi0g16.png" decode-test
+! "basi2c08.png" decode-test
+! "basi2c16.png" decode-test
+! "basi3p01.png" decode-test
+! "basi3p02.png" decode-test
+! "basi3p04.png" decode-test
+! "basi3p08.png" decode-test
+! "basi4a08.png" decode-test
+! "basi4a16.png" decode-test
+! "basi6a08.png" decode-test
+! "basi6a16.png" decode-test
+! "basn0g01.png" decode-test
+! "basn0g02.png" decode-test
+! "basn0g04.png" decode-test
+! "basn0g08.png" decode-test
+! "basn0g16.png" decode-test
+! "basn2c08.png" decode-test
+! "basn2c16.png" decode-test
+! "basn3p01.png" decode-test
+! "basn3p02.png" decode-test
+! "basn3p04.png" decode-test
+! "basn3p08.png" decode-test
+! "basn4a08.png" decode-test
+! "basn4a16.png" decode-test
+! "basn6a08.png" decode-test
+! "basn6a16.png" decode-test
+! "bgai4a08.png" decode-test
+! "bgai4a16.png" decode-test
+! "bgan6a08.png" decode-test
+! "bgan6a16.png" decode-test
+! "bgbn4a08.png" decode-test
+! "bggn4a16.png" decode-test
+! "bgwn6a08.png" decode-test
+! "bgyn6a16.png" decode-test
+! "ccwn2c08.png" decode-test
+! "ccwn3p08.png" decode-test
+! "cdfn2c08.png" decode-test
+! "cdhn2c08.png" decode-test
+! "cdsn2c08.png" decode-test
+! "cdun2c08.png" decode-test
+! "ch1n3p04.png" decode-test
+! "ch2n3p08.png" decode-test
+! "cm0n0g04.png" decode-test
+! "cm7n0g04.png" decode-test
+! "cm9n0g04.png" decode-test
+! "cs3n2c16.png" decode-test
+! "cs3n3p08.png" decode-test
+! "cs5n2c08.png" decode-test
+! "cs5n3p08.png" decode-test
+! "cs8n2c08.png" decode-test
+! "cs8n3p08.png" decode-test
+! "ct0n0g04.png" decode-test
+! "ct1n0g04.png" decode-test
+! "ctzn0g04.png" decode-test
+! "f00n0g08.png" decode-test
+! "f00n2c08.png" decode-test
+! "f01n0g08.png" decode-test
+! "f01n2c08.png" decode-test
+! "f02n0g08.png" decode-test
+! "f02n2c08.png" decode-test
+! "f03n0g08.png" decode-test
+! "f03n2c08.png" decode-test
+! "f04n0g08.png" decode-test
+! "f04n2c08.png" decode-test
+! "g03n0g16.png" decode-test
+! "g03n2c08.png" decode-test
+! "g03n3p04.png" decode-test
+! "g04n0g16.png" decode-test
+! "g04n2c08.png" decode-test
+! "g04n3p04.png" decode-test
+! "g05n0g16.png" decode-test
+! "g05n2c08.png" decode-test
+! "g05n3p04.png" decode-test
+! "g07n0g16.png" decode-test
+! "g07n2c08.png" decode-test
+! "g07n3p04.png" decode-test
+! "g10n0g16.png" decode-test
+! "g10n2c08.png" decode-test
+! "g10n3p04.png" decode-test
+! "g25n0g16.png" decode-test
+! "g25n2c08.png" decode-test
+! "g25n3p04.png" decode-test
+! "oi1n0g16.png" decode-test
+! "oi1n2c16.png" decode-test
+! "oi2n0g16.png" decode-test
+! "oi2n2c16.png" decode-test
+! "oi4n0g16.png" decode-test
+! "oi4n2c16.png" decode-test
+! "oi9n0g16.png" decode-test
+! "oi9n2c16.png" decode-test
+! "pngsuite_logo.png" decode-test
+! "pp0n2c16.png" decode-test
+! "pp0n6a08.png" decode-test
+! "ps1n0g08.png" decode-test
+! "ps1n2c16.png" decode-test
+! "ps2n0g08.png" decode-test
+! "ps2n2c16.png" decode-test
+! "s01i3p01.png" decode-test
+! "s01n3p01.png" decode-test
+! "s02i3p01.png" decode-test
+! "s02n3p01.png" decode-test
+! "s03i3p01.png" decode-test
+! "s03n3p01.png" decode-test
+! "s04i3p01.png" decode-test
+! "s04n3p01.png" decode-test
+! "s05i3p02.png" decode-test
+! "s05n3p02.png" decode-test
+! "s06i3p02.png" decode-test
+! "s06n3p02.png" decode-test
+! "s07i3p02.png" decode-test
+! "s07n3p02.png" decode-test
+! "s08i3p02.png" decode-test
+! "s08n3p02.png" decode-test
+! "s09i3p02.png" decode-test
+! "s09n3p02.png" decode-test
+! "s32i3p04.png" decode-test
+! "s32n3p04.png" decode-test
+! "s33i3p04.png" decode-test
+! "s33n3p04.png" decode-test
+! "s34i3p04.png" decode-test
+! "s34n3p04.png" decode-test
+! "s35i3p04.png" decode-test
+! "s35n3p04.png" decode-test
+! "s36i3p04.png" decode-test
+! "s36n3p04.png" decode-test
+! "s37i3p04.png" decode-test
+! "s37n3p04.png" decode-test
+! "s38i3p04.png" decode-test
+! "s38n3p04.png" decode-test
+! "s39i3p04.png" decode-test
+! "s39n3p04.png" decode-test
+! "s40i3p04.png" decode-test
+! "s40n3p04.png" decode-test
+! "tbbn1g04.png" decode-test
+! "tbbn2c16.png" decode-test
+! "tbbn3p08.png" decode-test
+! "tbgn2c16.png" decode-test
+! "tbgn3p08.png" decode-test
+! "tbrn2c08.png" decode-test
+! "tbwn1g16.png" decode-test
+! "tbwn3p08.png" decode-test
+! "tbyn3p08.png" decode-test
+! "tp0n1g08.png" decode-test
+! "tp0n2c08.png" decode-test
+! "tp0n3p08.png" decode-test
+! "tp1n3p08.png" decode-test
+! "x00n0g01.png" decode-test
+! "xcrn0g04.png" decode-test
+! "xlfn0g04.png" decode-test
+! "z00n2c08.png" decode-test
+! "z03n2c08.png" decode-test
+! "z06n2c08.png" decode-test
+! "z09n2c08.png" decode-test
+! ] with-directory
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays checksums checksums.crc32 combinators
+compression.inflate fry grouping images images.loader io
+io.binary io.encodings.ascii io.encodings.string kernel locals
+math math.bitwise math.ranges sequences sorting assocs
+math.functions math.order byte-arrays io.streams.throwing ;
+QUALIFIED-WITH: bitstreams bs
+IN: images.png
+
+SINGLETON: png-image
+"png" png-image register-image-class
+
+TUPLE: loading-png
+ chunks
+ width height bit-depth color-type compression-method
+ filter-method interlace-method uncompressed ;
+
+CONSTANT: filter-none 0
+CONSTANT: filter-sub 1
+CONSTANT: filter-up 2
+CONSTANT: filter-average 3
+CONSTANT: filter-paeth 4
+
+CONSTANT: greyscale 0
+CONSTANT: truecolor 2
+CONSTANT: indexed-color 3
+CONSTANT: greyscale-alpha 4
+CONSTANT: truecolor-alpha 6
+
+CONSTANT: interlace-none 0
+CONSTANT: interlace-adam7 1
+
+CONSTANT: starting-row { 0 0 4 0 2 0 1 }
+CONSTANT: starting-col { 0 4 0 2 0 1 0 }
+CONSTANT: row-increment { 8 8 8 4 4 2 2 }
+CONSTANT: col-increment { 8 8 4 4 2 2 1 }
+CONSTANT: block-height { 8 8 4 4 2 2 1 }
+CONSTANT: block-width { 8 4 4 2 2 1 1 }
+
+: <loading-png> ( -- image )
+ loading-png new
+ V{ } clone >>chunks ;
+
+TUPLE: png-chunk length type data ;
+
+: <png-chunk> ( -- png-chunk )
+ png-chunk new ; inline
+
+CONSTANT: png-header
+ B{ HEX: 89 HEX: 50 HEX: 4e HEX: 47 HEX: 0d HEX: 0a HEX: 1a HEX: 0a }
+
+ERROR: bad-png-header header ;
+
+: read-png-header ( -- )
+ 8 read dup png-header sequence= [
+ bad-png-header
+ ] unless drop ;
+
+ERROR: bad-checksum ;
+
+: read-png-chunks ( loading-png -- loading-png )
+ <png-chunk>
+ 4 read be> [ >>length ] [ 4 + ] bi
+ read dup crc32 checksum-bytes
+ 4 read = [ bad-checksum ] unless
+ 4 cut-slice
+ [ ascii decode >>type ] [ B{ } like >>data ] bi*
+ [ over chunks>> push ]
+ [ type>> ] bi "IEND" =
+ [ read-png-chunks ] unless ;
+
+: find-chunk ( loading-png string -- chunk )
+ [ chunks>> ] dip '[ type>> _ = ] find nip ;
+
+: find-chunks ( loading-png string -- chunk )
+ [ chunks>> ] dip '[ type>> _ = ] filter ;
+
+: parse-ihdr-chunk ( loading-png -- loading-png )
+ dup "IHDR" find-chunk data>> {
+ [ [ 0 4 ] dip subseq be> >>width ]
+ [ [ 4 8 ] dip subseq be> >>height ]
+ [ [ 8 ] dip nth >>bit-depth ]
+ [ [ 9 ] dip nth >>color-type ]
+ [ [ 10 ] dip nth >>compression-method ]
+ [ [ 11 ] dip nth >>filter-method ]
+ [ [ 12 ] dip nth >>interlace-method ]
+ } cleave ;
+
+: find-compressed-bytes ( loading-png -- bytes )
+ "IDAT" find-chunks [ data>> ] map concat ;
+
+ERROR: unknown-color-type n ;
+ERROR: unimplemented-color-type image ;
+
+: inflate-data ( loading-png -- bytes )
+ find-compressed-bytes zlib-inflate ;
+
+: png-components-per-pixel ( loading-png -- n )
+ color-type>> {
+ { greyscale [ 1 ] }
+ { truecolor [ 3 ] }
+ { greyscale-alpha [ 2 ] }
+ { indexed-color [ 1 ] }
+ { truecolor-alpha [ 4 ] }
+ [ unknown-color-type ]
+ } case ; inline
+
+: png-group-width ( loading-png -- n )
+ ! 1 + is for the filter type, 1 byte preceding each line
+ [ [ png-components-per-pixel ] [ bit-depth>> ] bi * ]
+ [ width>> ] bi * 1 + ;
+
+:: paeth ( a b c -- p )
+ a b + c - { a b c } [ [ - abs ] keep 2array ] with map
+ sort-keys first second ;
+
+:: png-unfilter-line ( width prev curr filter -- curr' )
+ prev :> c
+ prev width tail-slice :> b
+ curr :> a
+ curr width tail-slice :> x
+ x length iota
+ filter {
+ { filter-none [ drop ] }
+ { filter-sub [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] }
+ { filter-up [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] }
+ { filter-average [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] }
+ { filter-paeth [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] }
+ } case
+ curr width tail ;
+
+:: reverse-png-filter ( lines n -- byte-array )
+ lines dup first length 0 <array> prefix
+ [ n 1 - 0 <array> prepend ] map
+ 2 clump [
+ n swap first2
+ [ ]
+ [ n 1 - swap nth ]
+ [ [ 0 n 1 - ] dip set-nth ] tri
+ png-unfilter-line
+ ] map B{ } concat-as ;
+
+:: visit ( row col height width pixel image -- )
+ row image nth :> irow
+ pixel col irow set-nth ;
+
+ERROR: bad-filter n ;
+
+:: read-scanlines ( bit-reader loading-png width height -- array )
+ loading-png png-components-per-pixel :> #components
+ loading-png bit-depth>> :> bit-depth
+ bit-depth :> depth!
+ #components width * :> count!
+
+ ! Only read up to 8 bits at a time
+ bit-depth 16 = [
+ 8 depth!
+ count 2 * count!
+ ] when
+
+ height [
+ 8 bit-reader bs:read dup 0 4 between? [ bad-filter ] unless
+ count [ depth bit-reader bs:read ] replicate swap prefix
+ 8 bit-reader bs:align
+ ] replicate
+ #components bit-depth 16 = [ 2 * ] when reverse-png-filter ;
+
+:: reverse-interlace-none ( byte-array loading-png -- array )
+ byte-array bs:<msb0-bit-reader> :> bs
+ loading-png width>> :> width
+ loading-png height>> :> height
+ bs loading-png width height read-scanlines ;
+
+:: adam7-subimage-height ( png-height pass -- subimage-height )
+ pass starting-row nth png-height >= [
+ 0
+ ] [
+ png-height 1 -
+ pass block-height nth +
+ pass row-increment nth /i
+ ] if ;
+
+:: adam7-subimage-width ( png-width pass -- subimage-width )
+ pass starting-col nth png-width >= [
+ 0
+ ] [
+ png-width 1 -
+ pass block-width nth +
+ pass col-increment nth /i
+ ] if ;
+
+:: read-adam7-subimage ( bit-reader loading-png pass -- lines )
+ loading-png height>> pass adam7-subimage-height :> height
+ loading-png width>> pass adam7-subimage-width :> width
+
+ height width * zero? [
+ B{ } clone
+ ] [
+ bit-reader loading-png width height read-scanlines
+ ] if ;
+
+:: reverse-interlace-adam7 ( byte-array loading-png -- byte-array )
+ byte-array bs:<msb0-bit-reader> :> bs
+ loading-png height>> :> height
+ loading-png width>> :> width
+ loading-png bit-depth>> :> bit-depth
+ loading-png png-components-per-pixel :> #bytes!
+ width height * f <array> width <sliced-groups> :> image
+
+ bit-depth 16 = [
+ #bytes 2 * #bytes!
+ ] when
+
+ 0 :> row!
+ 0 :> col!
+
+ 0 :> pass!
+ [ pass 7 < ] [
+ bs loading-png pass read-adam7-subimage
+
+ #bytes <sliced-groups>
+
+ pass starting-row nth row!
+ pass starting-col nth col!
+ [
+ [ row col f f ] dip image visit
+
+ col pass col-increment nth + col!
+ col width >= [
+ pass starting-col nth col!
+ row pass row-increment nth + row!
+ ] when
+ ] each
+
+ pass 1 + pass!
+ ] while
+ image concat B{ } concat-as ;
+
+ERROR: unimplemented-interlace ;
+
+: uncompress-bytes ( loading-png -- bitstream )
+ [ inflate-data ] [ ] [ interlace-method>> ] tri {
+ { interlace-none [ reverse-interlace-none ] }
+ { interlace-adam7 [ reverse-interlace-adam7 ] }
+ [ unimplemented-interlace ]
+ } case ;
+
+ERROR: unknown-component-type n ;
+
+: png-component ( loading-png -- obj )
+ bit-depth>> {
+ { 1 [ ubyte-components ] }
+ { 2 [ ubyte-components ] }
+ { 4 [ ubyte-components ] }
+ { 8 [ ubyte-components ] }
+ { 16 [ ushort-components ] }
+ [ unknown-component-type ]
+ } case ;
+
+: scale-factor ( n -- n' )
+ {
+ { 1 [ 255 ] }
+ { 2 [ 85 ] }
+ { 4 [ 17 ] }
+ } case ;
+
+: scale-greyscale ( byte-array loading-png -- byte-array' )
+ bit-depth>> {
+ { 8 [ ] }
+ { 16 [ 2 group [ swap ] assoc-map B{ } concat-as ] }
+ [ scale-factor '[ _ * ] B{ } map-as ]
+ } case ;
+
+: decode-greyscale ( loading-png -- byte-array )
+ [ uncompress-bytes ] keep scale-greyscale ;
+
+: decode-greyscale-alpha ( loading-image -- byte-array )
+ [ uncompress-bytes ] [ bit-depth>> ] bi 16 = [
+ 4 group [ first4 [ swap ] 2dip 4array ] map B{ } concat-as
+ ] when ;
+
+ERROR: invalid-PLTE array ;
+
+: verify-PLTE ( seq -- seq )
+ dup length 3 divisor? [ invalid-PLTE ] unless ;
+
+: decode-indexed-color ( loading-image -- byte-array )
+ [ uncompress-bytes ] keep
+ "PLTE" find-chunk data>> verify-PLTE
+ 3 group '[ _ nth ] { } map-as B{ } concat-as ;
+
+ERROR: invalid-color-type/bit-depth loading-png ;
+
+: validate-bit-depth ( loading-png seq -- loading-png )
+ [ dup bit-depth>> ] dip member?
+ [ invalid-color-type/bit-depth ] unless ;
+
+: validate-greyscale ( loading-png -- loading-png )
+ { 1 2 4 8 16 } validate-bit-depth ;
+
+: validate-truecolor ( loading-png -- loading-png )
+ { 8 16 } validate-bit-depth ;
+
+: validate-indexed-color ( loading-png -- loading-png )
+ { 1 2 4 8 } validate-bit-depth ;
+
+: validate-greyscale-alpha ( loading-png -- loading-png )
+ { 8 16 } validate-bit-depth ;
+
+: validate-truecolor-alpha ( loading-png -- loading-png )
+ { 8 16 } validate-bit-depth ;
+
+: loading-png>bitmap ( loading-png -- bytes component-order )
+ dup color-type>> {
+ { greyscale [
+ validate-greyscale decode-greyscale L
+ ] }
+ { truecolor [
+ validate-truecolor uncompress-bytes RGB
+ ] }
+ { indexed-color [
+ validate-indexed-color decode-indexed-color RGB
+ ] }
+ { greyscale-alpha [
+ validate-greyscale-alpha decode-greyscale-alpha LA
+ ] }
+ { truecolor-alpha [
+ validate-truecolor-alpha uncompress-bytes RGBA
+ ] }
+ [ unknown-color-type ]
+ } case ;
+
+: loading-png>image ( loading-png -- image )
+ [ image new ] dip {
+ [ loading-png>bitmap [ >>bitmap ] [ >>component-order ] bi* ]
+ [ [ width>> ] [ height>> ] bi 2array >>dim ]
+ [ png-component >>component-type ]
+ } cleave ;
+
+: load-png ( stream -- loading-png )
+ [
+ [
+ <loading-png>
+ read-png-header
+ read-png-chunks
+ parse-ihdr-chunk
+ ] throw-on-eof
+ ] with-input-stream ;
+
+M: png-image stream>image
+ drop load-png loading-png>image ;
--- /dev/null
+Erik Charlebois
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: images.testing ;
+IN: images.ppm.tests
+
+"vocab:images/testing/ppm/binary.ppm" decode-test
+"vocab:images/testing/ppm/ascii.ppm" decode-test
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors ascii combinators images images.loader io
+io.encodings.ascii io.encodings.string kernel locals make math
+math.parser sequences io.streams.throwing ;
+IN: images.ppm
+
+SINGLETON: ppm-image
+"ppm" ppm-image register-image-class
+
+: read-token ( -- token )
+ [ read1 dup blank?
+ [ t ]
+ [ dup CHAR: # =
+ [ "\n" read-until 2drop t ]
+ [ f ] if
+ ] if
+ ] [ drop ] while
+ " \n\r\t" read-until drop swap
+ prefix ascii decode ;
+
+: read-number ( -- number )
+ read-token string>number ;
+
+:: read-numbers ( n lim -- )
+ n lim = [
+ read-number ,
+ n 1 + lim read-numbers
+ ] unless ;
+
+:: read-ppm ( -- image )
+ read-token :> type
+ read-number :> width
+ read-number :> height
+ read-number :> max
+ width height 3 * * :> npixels
+ type {
+ { "P3" [ [ 0 npixels read-numbers ] B{ } make ] }
+ { "P6" [ npixels read ] }
+ } case :> data
+
+ image new
+ RGB >>component-order
+ { width height } >>dim
+ f >>upside-down?
+ data >>bitmap
+ ubyte-components >>component-type ;
+
+M: ppm-image stream>image
+ drop [ [ read-ppm ] throw-on-eof ] with-input-stream ;
+
+M: ppm-image image>stream
+ drop {
+ [ drop "P6\n" ascii encode write ]
+ [ dim>> first number>string " " append ascii encode write ]
+ [ dim>> second number>string "\n" append ascii encode write ]
+ [ drop "255\n" ascii encode write ]
+ [ bitmap>> write ]
+ } cleave ;
--- /dev/null
+Image loading for PPM image files.
--- /dev/null
+Erik Charlebois
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors images images.loader io io.binary kernel
+locals math sequences io.encodings.ascii io.encodings.string
+calendar math.ranges math.parser colors arrays hashtables
+ui.pixel-formats combinators continuations io.streams.throwing ;
+IN: images.tga
+
+SINGLETON: tga-image
+"tga" tga-image register-image-class
+
+ERROR: bad-tga-header ;
+ERROR: bad-tga-footer ;
+ERROR: bad-tga-extension-size ;
+ERROR: bad-tga-timestamp ;
+ERROR: bad-tga-unsupported ;
+
+: read-id-length ( -- byte )
+ 1 read le> ; inline
+
+: read-color-map-type ( -- byte )
+ 1 read le> dup
+ { 0 1 } member? [ bad-tga-header ] unless ;
+
+: read-image-type ( -- byte )
+ 1 read le> dup
+ { 0 1 2 3 9 10 11 } member? [ bad-tga-header ] unless ; inline
+
+: read-color-map-first ( -- short )
+ 2 read le> ; inline
+
+: read-color-map-length ( -- short )
+ 2 read le> ; inline
+
+: read-color-map-entry-size ( -- byte )
+ 1 read le> ; inline
+
+: read-x-origin ( -- short )
+ 2 read le> ; inline
+
+: read-y-origin ( -- short )
+ 2 read le> ; inline
+
+: read-image-width ( -- short )
+ 2 read le> ; inline
+
+: read-image-height ( -- short )
+ 2 read le> ; inline
+
+: read-pixel-depth ( -- byte )
+ 1 read le> ; inline
+
+: read-image-descriptor ( -- alpha-bits pixel-order )
+ 1 read le>
+ [ 7 bitand ] [ 24 bitand -3 shift ] bi ; inline
+
+: read-image-id ( length -- image-id )
+ read ; inline
+
+: read-color-map ( type length elt-size -- color-map )
+ pick 1 = [ 8 align 8 / * read ] [ 2drop f ] if swap drop ; inline
+
+: read-image-data ( width height depth -- image-data )
+ 8 align 8 / * * read ; inline
+
+: read-extension-area-offset ( -- offset )
+ 4 read le> ; inline
+
+: read-developer-directory-offset ( -- offset )
+ 4 read le> ; inline
+
+: read-signature ( -- )
+ 18 read ascii decode "TRUEVISION-XFILE.\0" = [ bad-tga-footer ] unless ; inline
+
+: read-extension-size ( -- )
+ 2 read le> 495 = [ bad-tga-extension-size ] unless ; inline
+
+: read-author-name ( -- string )
+ 41 read ascii decode [ 0 = ] trim ; inline
+
+: read-author-comments ( -- string )
+ 4 iota [ drop 81 read ascii decode [ 0 = ] trim ] map concat ; inline
+
+: read-date-timestamp ( -- timestamp )
+ timestamp new
+ 2 read le> dup 12 [1,b] member? [ bad-tga-timestamp ] unless >>month
+ 2 read le> dup 31 [1,b] member? [ bad-tga-timestamp ] unless >>day
+ 2 read le> >>year
+ 2 read le> dup 23 [0,b] member? [ bad-tga-timestamp ] unless >>hour
+ 2 read le> dup 59 [0,b] member? [ bad-tga-timestamp ] unless >>minute
+ 2 read le> dup 59 [0,b] member? [ bad-tga-timestamp ] unless >>second ; inline
+
+: read-job-name ( -- string )
+ 41 read ascii decode [ 0 = ] trim ; inline
+
+: read-job-time ( -- duration )
+ duration new
+ 2 read le> >>hour
+ 2 read le> dup 59 [0,b] member? [ bad-tga-timestamp ] unless >>minute
+ 2 read le> dup 59 [0,b] member? [ bad-tga-timestamp ] unless >>second ; inline
+
+: read-software-id ( -- string )
+ 41 read ascii decode [ 0 = ] trim ; inline
+
+: read-software-version ( -- string )
+ 2 read le> 100 /f number>string
+ 1 read ascii decode append [ " " = ] trim ; inline
+
+:: read-key-color ( -- color )
+ 1 read le> 255 /f :> alpha
+ 1 read le> 255 /f
+ 1 read le> 255 /f
+ 1 read le> 255 /f
+ alpha <rgba> ; inline
+
+: read-pixel-aspect-ratio ( -- aspect-ratio )
+ 2 read le> 2 read le> /f ; inline
+
+: read-gamma-value ( -- gamma-value )
+ 2 read le> 2 read le> /f ; inline
+
+: read-color-correction-offset ( -- offset )
+ 4 read le> ; inline
+
+: read-postage-stamp-offset ( -- offset )
+ 4 read le> ; inline
+
+: read-scan-line-offset ( -- offset )
+ 4 read le> ; inline
+
+: read-premultiplied-alpha ( -- boolean )
+ 1 read le> 4 = ; inline
+
+: read-scan-line-table ( height -- scan-offsets )
+ iota [ drop 4 read le> ] map ; inline
+
+: read-postage-stamp-image ( depth -- postage-data )
+ 8 align 8 / 1 read le> 1 read le> * * read ; inline
+
+:: read-color-correction-table ( -- correction-table )
+ 256 iota
+ [
+ drop
+ 4 iota
+ [
+ drop
+ 2 read le> 65535 /f :> alpha
+ 2 read le> 65535 /f
+ 2 read le> 65535 /f
+ 2 read le> 65535 /f
+ alpha <rgba>
+ ] map
+ ] map ; inline
+
+: read-developer-directory ( -- developer-directory )
+ 2 read le> iota
+ [
+ drop
+ 2 read le>
+ 4 read le>
+ 4 read le>
+ 3array
+ ] map ; inline
+
+: read-developer-areas ( developer-directory -- developer-area-map )
+ [
+ [ first ]
+ [ dup third second seek-absolute seek-input read ] bi 2array
+ ] map >hashtable ; inline
+
+:: read-tga ( -- image )
+ #! Read header
+ read-id-length :> id-length
+ read-color-map-type :> map-type
+ read-image-type :> image-type
+ read-color-map-first :> map-first
+ read-color-map-length :> map-length
+ read-color-map-entry-size :> map-entry-size
+ read-x-origin :> x-origin
+ read-y-origin :> y-origin
+ read-image-width :> image-width
+ read-image-height :> image-height
+ read-pixel-depth :> pixel-depth
+ read-image-descriptor :> ( alpha-bits pixel-order )
+ id-length read-image-id :> image-id
+ map-type map-length map-entry-size read-color-map :> color-map-data
+ image-width image-height pixel-depth read-image-data :> image-data
+
+ [
+ #! Read optional footer
+ 26 seek-end seek-input
+ read-extension-area-offset :> extension-offset
+ read-developer-directory-offset :> directory-offset
+ read-signature
+
+ #! Read optional extension section
+ extension-offset 0 =
+ [
+ extension-offset seek-absolute seek-input
+ read-extension-size
+ read-author-name :> author-name
+ read-author-comments :> author-comments
+ read-date-timestamp :> date-timestamp
+ read-job-name :> job-name
+ read-job-time :> job-time
+ read-software-id :> software-id
+ read-software-version :> software-version
+ read-key-color :> key-color
+ read-pixel-aspect-ratio :> aspect-ratio
+ read-gamma-value :> gamma-value
+ read-color-correction-offset :> color-correction-offset
+ read-postage-stamp-offset :> postage-stamp-offset
+ read-scan-line-offset :> scan-line-offset
+ read-premultiplied-alpha :> premultiplied-alpha
+
+ color-correction-offset 0 =
+ [
+ color-correction-offset seek-absolute seek-input
+ read-color-correction-table :> color-correction-table
+ ] unless
+
+ postage-stamp-offset 0 =
+ [
+ postage-stamp-offset seek-absolute seek-input
+ pixel-depth read-postage-stamp-image :> postage-data
+ ] unless
+
+ scan-line-offset seek-absolute seek-input
+ image-height read-scan-line-table :> scan-offsets
+
+ #! Read optional developer section
+ directory-offset 0 =
+ [ f ]
+ [
+ directory-offset seek-absolute seek-input
+ read-developer-directory read-developer-areas
+ ] if :> developer-areas
+ ] unless
+ ] ignore-errors
+
+ #! Only 24-bit uncompressed BGR and 32-bit uncompressed BGRA are supported.
+ #! Other formats would need to be converted to work within the image class.
+ map-type 0 = [ bad-tga-unsupported ] unless
+ image-type 2 = [ bad-tga-unsupported ] unless
+ pixel-depth { 24 32 } member? [ bad-tga-unsupported ] unless
+ pixel-order { 0 2 } member? [ bad-tga-unsupported ] unless
+
+ #! Create image instance
+ image new
+ alpha-bits 0 = [ BGR ] [ BGRA ] if >>component-order
+ { image-width image-height } >>dim
+ pixel-order 0 = >>upside-down?
+ image-data >>bitmap
+ ubyte-components >>component-type ;
+
+M: tga-image stream>image
+ drop [ [ read-tga ] throw-on-eof ] with-input-stream ;
+
+M: tga-image image>stream
+ drop
+ [
+ component-order>> { BGRA BGRA } member? [ bad-tga-unsupported ] unless
+ ] keep
+
+ B{ 0 } write #! id-length
+ B{ 0 } write #! map-type
+ B{ 2 } write #! image-type
+ B{ 0 0 0 0 0 } write #! color map first, length, entry size
+ B{ 0 0 0 0 } write #! x-origin, y-origin
+ {
+ [ dim>> first 2 >le write ]
+ [ dim>> second 2 >le write ]
+ [ component-order>>
+ {
+ { BGR [ B{ 24 } write ] }
+ { BGRA [ B{ 32 } write ] }
+ } case
+ ]
+ [
+ dup component-order>>
+ {
+ { BGR [ 0 ] }
+ { BGRA [ 8 ] }
+ } case swap
+ upside-down?>> [ 0 ] [ 2 ] if 3 shift bitor
+ 1 >le write
+ ]
+ [ bitmap>> write ]
+ } cleave ;
+
--- /dev/null
+Doug Coleman
--- /dev/null
+TIFF image loader
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: images.testing ;
+IN: images.tiff.tests
+
+"vocab:images/testing/tiff/octagon.tiff" decode-test
+! "vocab:images/testing/tiff/elephants.tiff" decode-test
+"vocab:images/testing/tiff/noise.tiff" decode-test
+"vocab:images/testing/tiff/alpha.tiff" decode-test
+"vocab:images/testing/tiff/color_spectrum.tiff" decode-test
+"vocab:images/testing/tiff/rgb.tiff" decode-test
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs byte-arrays classes combinators
+compression.lzw endian fry grouping images io
+io.binary io.encodings.ascii io.encodings.binary
+io.encodings.string io.encodings.utf8 io.files kernel math
+math.bitwise math.order math.parser pack sequences
+strings math.vectors specialized-arrays locals
+images.loader io.streams.throwing ;
+FROM: alien.c-types => float ;
+SPECIALIZED-ARRAY: float
+IN: images.tiff
+
+SINGLETON: tiff-image
+
+TUPLE: loading-tiff endianness the-answer ifd-offset ifds ;
+
+: <loading-tiff> ( -- tiff )
+ loading-tiff new V{ } clone >>ifds ;
+
+TUPLE: ifd count ifd-entries next
+processed-tags strips bitmap ;
+
+: <ifd> ( count ifd-entries next -- ifd )
+ ifd new
+ swap >>next
+ swap >>ifd-entries
+ swap >>count ;
+
+TUPLE: ifd-entry tag type count offset/value ;
+
+: <ifd-entry> ( tag type count offset/value -- ifd-entry )
+ ifd-entry new
+ swap >>offset/value
+ swap >>count
+ swap >>type
+ swap >>tag ;
+
+SINGLETONS: photometric-interpretation
+photometric-interpretation-white-is-zero
+photometric-interpretation-black-is-zero
+photometric-interpretation-rgb
+photometric-interpretation-palette-color
+photometric-interpretation-transparency-mask
+photometric-interpretation-separated
+photometric-interpretation-ycbcr
+photometric-interpretation-cielab
+photometric-interpretation-icclab
+photometric-interpretation-itulab
+photometric-interpretation-logl
+photometric-interpretation-logluv ;
+
+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 ] }
+ { 4 [ photometric-interpretation-transparency-mask ] }
+ { 5 [ photometric-interpretation-separated ] }
+ { 6 [ photometric-interpretation-ycbcr ] }
+ { 8 [ photometric-interpretation-cielab ] }
+ { 9 [ photometric-interpretation-icclab ] }
+ { 10 [ photometric-interpretation-itulab ] }
+ { 32844 [ photometric-interpretation-logl ] }
+ { 32845 [ photometric-interpretation-logluv ] }
+ [ bad-photometric-interpretation ]
+ } case ;
+
+SINGLETONS: compression
+compression-none
+compression-CCITT-2
+compression-CCITT-3
+compression-CCITT-4
+compression-lzw
+compression-jpeg-old
+compression-jpeg-new
+compression-adobe-deflate
+compression-9
+compression-10
+compression-deflate
+compression-next
+compression-ccittrlew
+compression-pack-bits
+compression-thunderscan
+compression-it8ctpad
+compression-it8lw
+compression-it8mp
+compression-it8bl
+compression-pixarfilm
+compression-pixarlog
+compression-dcs
+compression-jbig
+compression-sgilog
+compression-sgilog24
+compression-jp2000 ;
+ERROR: bad-compression n ;
+: lookup-compression ( n -- compression )
+ {
+ { 1 [ compression-none ] }
+ { 2 [ compression-CCITT-2 ] }
+ { 3 [ compression-CCITT-3 ] }
+ { 4 [ compression-CCITT-4 ] }
+ { 5 [ compression-lzw ] }
+ { 6 [ compression-jpeg-old ] }
+ { 7 [ compression-jpeg-new ] }
+ { 8 [ compression-adobe-deflate ] }
+ { 9 [ compression-9 ] }
+ { 10 [ compression-10 ] }
+ { 32766 [ compression-next ] }
+ { 32771 [ compression-ccittrlew ] }
+ { 32773 [ compression-pack-bits ] }
+ { 32809 [ compression-thunderscan ] }
+ { 32895 [ compression-it8ctpad ] }
+ { 32896 [ compression-it8lw ] }
+ { 32897 [ compression-it8mp ] }
+ { 32898 [ compression-it8bl ] }
+ { 32908 [ compression-pixarfilm ] }
+ { 32909 [ compression-pixarlog ] }
+ { 32946 [ compression-deflate ] }
+ { 32947 [ compression-dcs ] }
+ { 34661 [ compression-jbig ] }
+ { 34676 [ compression-sgilog ] }
+ { 34677 [ compression-sgilog24 ] }
+ { 34712 [ compression-jp2000 ] }
+ [ 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-none
+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 )
+ [
+ {
+ { 0 [ sample-format-none ] }
+ { 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 subfile-type orientation
+software date-time photoshop exif-ifd sub-ifd inter-color-profile
+xmp iptc fill-order document-name page-number page-name
+x-position y-position host-computer copyright artist
+min-sample-value max-sample-value tiff-make tiff-model cell-width cell-length
+gray-response-unit gray-response-curve color-map threshholding
+image-description free-offsets free-byte-counts tile-width tile-length
+matteing data-type image-depth tile-depth
+ycbcr-subsampling gdal-metadata
+tile-offsets tile-byte-counts jpeg-qtables jpeg-dctables jpeg-actables
+ycbcr-positioning ycbcr-coefficients reference-black-white halftone-hints
+jpeg-interchange-format
+jpeg-interchange-format-length
+jpeg-restart-interval jpeg-tables
+t4-options clean-fax-data bad-fax-lines consecutive-bad-fax-lines
+sto-nits print-image-matching-info
+unhandled-ifd-entry ;
+
+SINGLETONS: jpeg-proc
+jpeg-proc-baseline
+jpeg-proc-lossless ;
+
+ERROR: bad-jpeg-proc n ;
+
+: lookup-jpeg-proc ( sequence -- object )
+ {
+ { 1 [ jpeg-proc-baseline ] }
+ { 14 [ jpeg-proc-lossless ] }
+ [ bad-jpeg-proc ]
+ } case ;
+
+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 offset -- tiff )
+ seek-absolute seek-input
+ 2 read endian>
+ dup [ read-ifd ] replicate
+ 4 read endian>
+ [ <ifd> push-ifd ] [ dup 0 = [ drop ] [ read-ifds ] if ] bi ;
+
+ERROR: no-tag class ;
+
+: find-tag* ( ifd class -- tag/class ? )
+ swap processed-tags>> ?at ;
+
+: find-tag ( ifd class -- tag )
+ find-tag* [ no-tag ] unless ;
+
+: tag? ( ifd class -- tag )
+ swap processed-tags>> key? ;
+
+: 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 * ] }
+ { 13 [ 4 * ] }
+ [ 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 ] }
+ { 13 [ endian> 32 >signed ] }
+ [ 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 ] }
+ { 255 [ subfile-type ] }
+ { 256 [ image-width ] }
+ { 257 [ image-length ] }
+ { 258 [ bits-per-sample ] }
+ { 259 [ lookup-compression compression ] }
+ { 262 [ lookup-photometric-interpretation photometric-interpretation ] }
+ { 263 [ threshholding ] }
+ { 264 [ cell-width ] }
+ { 265 [ cell-length ] }
+ { 266 [ fill-order ] }
+ { 269 [ ascii decode document-name ] }
+ { 270 [ ascii decode image-description ] }
+ { 271 [ ascii decode tiff-make ] }
+ { 272 [ ascii decode tiff-model ] }
+ { 273 [ strip-offsets ] }
+ { 274 [ orientation ] }
+ { 277 [ samples-per-pixel ] }
+ { 278 [ rows-per-strip ] }
+ { 279 [ strip-byte-counts ] }
+ { 280 [ min-sample-value ] }
+ { 281 [ max-sample-value ] }
+ { 282 [ first x-resolution ] }
+ { 283 [ first y-resolution ] }
+ { 284 [ lookup-planar-configuration planar-configuration ] }
+ { 285 [ page-name ] }
+ { 286 [ x-position ] }
+ { 287 [ y-position ] }
+ { 288 [ free-offsets ] }
+ { 289 [ free-byte-counts ] }
+ { 290 [ gray-response-unit ] }
+ { 291 [ gray-response-curve ] }
+ { 292 [ t4-options ] }
+ { 296 [ lookup-resolution-unit resolution-unit ] }
+ { 297 [ page-number ] }
+ { 305 [ ascii decode software ] }
+ { 306 [ ascii decode date-time ] }
+ { 315 [ ascii decode artist ] }
+ { 316 [ ascii decode host-computer ] }
+ { 317 [ lookup-predictor predictor ] }
+ { 320 [ color-map ] }
+ { 321 [ halftone-hints ] }
+ { 322 [ tile-width ] }
+ { 323 [ tile-length ] }
+ { 324 [ tile-offsets ] }
+ { 325 [ tile-byte-counts ] }
+ { 326 [ bad-fax-lines ] }
+ { 327 [ clean-fax-data ] }
+ { 328 [ consecutive-bad-fax-lines ] }
+ { 330 [ sub-ifd ] }
+ { 338 [ lookup-extra-samples extra-samples ] }
+ { 339 [ lookup-sample-format sample-format ] }
+ { 347 [ jpeg-tables ] }
+ { 512 [ lookup-jpeg-proc jpeg-proc ] }
+ { 513 [ jpeg-interchange-format ] }
+ { 514 [ jpeg-interchange-format-length ] }
+ { 515 [ jpeg-restart-interval ] }
+ { 519 [ jpeg-qtables ] }
+ { 520 [ jpeg-dctables ] }
+ { 521 [ jpeg-actables ] }
+ { 529 [ ycbcr-coefficients ] }
+ { 530 [ ycbcr-subsampling ] }
+ { 531 [ ycbcr-positioning ] }
+ { 532 [ reference-black-white ] }
+ { 700 [ utf8 decode xmp ] }
+ { 32995 [ matteing ] }
+ { 32996 [ data-type ] }
+ { 32997 [ image-depth ] }
+ { 32998 [ tile-depth ] }
+ { 33432 [ copyright ] }
+ { 33723 [ iptc ] }
+ { 34377 [ photoshop ] }
+ { 34665 [ exif-ifd ] }
+ { 34675 [ inter-color-profile ] }
+ { 37439 [ sto-nits ] }
+ { 42112 [ gdal-metadata ] }
+ { 50341 [ print-image-matching-info ] }
+ [ nip unhandled-ifd-entry swap ]
+ } case ;
+
+: process-ifds ( loading-tiff -- loading-tiff )
+ [
+ [
+ dup ifd-entries>>
+ [ process-ifd-entry swap ] H{ } map>assoc >>processed-tags
+ ] map
+ ] change-ifds ;
+
+ERROR: unhandled-compression compression ;
+
+: (uncompress-strips) ( strips compression -- uncompressed-strips )
+ {
+ { compression-none [ ] }
+ { compression-lzw [ [ tiff-lzw-uncompress ] map ] }
+ [ unhandled-compression ]
+ } case ;
+
+: uncompress-strips ( ifd -- ifd )
+ dup '[
+ _ compression find-tag (uncompress-strips)
+ ] change-strips ;
+
+: strips>bitmap ( ifd -- ifd )
+ dup strips>> concat >>bitmap ;
+
+: (strips-predictor) ( ifd -- ifd )
+ [ ]
+ [ image-width find-tag ]
+ [ samples-per-pixel find-tag ] tri
+ [ * ] keep
+ '[
+ _ group
+ [ _ group unclip [ v+ ] accumulate swap suffix concat ] map
+ B{ } concat-as
+ ] change-bitmap ;
+
+: strips-predictor ( ifd -- ifd )
+ dup predictor tag? [
+ dup predictor find-tag
+ {
+ { predictor-none [ ] }
+ { predictor-horizontal-differencing [ (strips-predictor) ] }
+ [ bad-predictor ]
+ } case
+ ] when ;
+
+ERROR: unknown-component-order ifd ;
+
+: fix-bitmap-endianness ( ifd -- ifd )
+ dup [ bitmap>> ] [ bits-per-sample find-tag ] bi
+ {
+ { { 32 32 32 32 } [ 4 seq>native-endianness ] }
+ { { 32 32 32 } [ 4 seq>native-endianness ] }
+ { { 16 16 16 16 } [ 2 seq>native-endianness ] }
+ { { 16 16 16 } [ 2 seq>native-endianness ] }
+ { { 8 8 8 8 } [ ] }
+ { { 8 8 8 } [ ] }
+ { 8 [ ] }
+ [ unknown-component-order ]
+ } case >>bitmap ;
+
+: ifd-component-order ( ifd -- component-order component-type )
+ bits-per-sample find-tag {
+ { { 32 32 32 32 } [ RGBA float-components ] }
+ { { 32 32 32 } [ RGB float-components ] }
+ { { 16 16 16 16 } [ RGBA ushort-components ] }
+ { { 16 16 16 } [ RGB ushort-components ] }
+ { { 8 8 8 8 } [ RGBA ubyte-components ] }
+ { { 8 8 8 } [ RGB ubyte-components ] }
+ { 8 [ LA ubyte-components ] }
+ [ unknown-component-order ]
+ } case ;
+
+: handle-alpha-data ( ifd -- ifd )
+ dup extra-samples find-tag {
+ { extra-samples-associated-alpha-data [ ] }
+ { extra-samples-unspecified-alpha-data [ ] }
+ { extra-samples-unassociated-alpha-data [ ] }
+ [ bad-extra-samples ]
+ } case ;
+
+: ifd>image ( ifd -- image )
+ [ <image> ] dip {
+ [ [ image-width find-tag ] [ image-length find-tag ] bi 2array >>dim ]
+ [ ifd-component-order [ >>component-order ] [ >>component-type ] bi* ]
+ [ bitmap>> >>bitmap ]
+ } cleave ;
+
+: tiff>image ( image -- image )
+ ifds>> [ ifd>image ] map first ;
+
+: with-tiff-endianness ( loading-tiff quot -- )
+ [ dup endianness>> ] dip with-endianness ; inline
+
+: load-tiff-ifds ( -- loading-tiff )
+ <loading-tiff>
+ read-header [
+ dup ifd-offset>> read-ifds
+ process-ifds
+ ] with-tiff-endianness ;
+
+: process-chunky-ifd ( ifd -- )
+ read-strips
+ uncompress-strips
+ strips>bitmap
+ fix-bitmap-endianness
+ strips-predictor
+ dup extra-samples tag? [ handle-alpha-data ] when
+ drop ;
+
+: process-planar-ifd ( ifd -- )
+ "planar ifd not supported" throw ;
+
+: dispatch-planar-configuration ( ifd planar-configuration -- )
+ {
+ { planar-configuration-chunky [ process-chunky-ifd ] }
+ { planar-configuration-planar [ process-planar-ifd ] }
+ } case ;
+
+: process-ifd ( ifd -- )
+ dup planar-configuration find-tag* [
+ dispatch-planar-configuration
+ ] [
+ drop "no planar configuration" throw
+ ] if ;
+
+: process-tif-ifds ( loading-tiff -- )
+ ifds>> [ process-ifd ] each ;
+
+: load-tiff ( -- loading-tiff )
+ load-tiff-ifds dup
+ 0 seek-absolute seek-input
+ [ process-tif-ifds ] with-tiff-endianness ;
+
+! tiff files can store several images -- we just take the first for now
+M: tiff-image stream>image ( stream tiff-image -- image )
+ drop [ [ load-tiff tiff>image ] throw-on-eof ] with-input-stream ;
+
+{ "tif" "tiff" } [ tiff-image register-image-class ] each
projects / factor.git / commitdiff