tools.test math random ;
IN: bit-arrays.tests
+[ -1 <bit-array> ] [ T{ bad-array-length f -1 } = ] must-fail-with
+
[ 100 ] [ 100 <bit-array> length ] unit-test
[
-! Copyright (C) 2007, 2010 Slava Pestov.
+! Copyright (C) 2007, 2011 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.data accessors io.binary math math.bitwise
alien.accessors kernel kernel.private sequences
PRIVATE>
+ERROR: bad-array-length n ;
+
: <bit-array> ( n -- bit-array )
- dup bits>bytes <byte-array> bit-array boa ; inline
+ dup 0 < [ bad-array-length ] when
+ dup bits>bytes <byte-array>
+ bit-array boa ; inline
M: bit-array length length>> ; inline
CTLineCreateWithAttributedString
] with-destructors ;
-TUPLE: line < disposable line metrics image loc dim ;
+TUPLE: line < disposable line metrics image loc dim rendered-line ;
+
+TUPLE: rendered-line font string loc dim ;
+C: <rendered-line> rendered-line
: typographic-bounds ( line -- width ascent descent leading )
{ CGFloat CGFloat CGFloat }
line >>line
- metrics >>metrics
+ font string loc dim <rendered-line> >>rendered-line
- dim [
- {
- [ font dim fill-background ]
- [ loc dim line string fill-selection-background ]
- [ loc set-text-position ]
- [ [ line ] dip CTLineDraw ]
- } cleave
- ] make-bitmap-image >>image
+ metrics >>metrics
metrics loc dim line-loc >>loc
metrics metrics>dim >>dim
] with-destructors ;
+:: render ( line -- line image )
+ line line>> :> ctline
+ line rendered-line>> string>> :> string
+ line rendered-line>> font>> :> font
+ line rendered-line>> loc>> :> loc
+ line rendered-line>> dim>> :> dim
+
+ line dim [
+ {
+ [ font dim fill-background ]
+ [ loc dim ctline string fill-selection-background ]
+ [ loc set-text-position ]
+ [ [ ctline ] dip CTLineDraw ]
+ } cleave
+ ] make-bitmap-image ;
+
+: line>image ( line -- image )
+ dup image>> [ render >>image ] unless image>> ;
+
M: line dispose* line>> CFRelease ;
SYMBOL: cached-lines
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.data alien.libraries alien.syntax
combinators gio.ffi glib.ffi gmodule.ffi gobject-introspection
-gobject.ffi kernel libc sequences system ;
+gobject.ffi kernel libc sequences system vocabs.loader ;
EXCLUDE: alien.c-types => pointer ;
IN: gdk.pixbuf.ffi
! Copyright (C) 2010 Anton Gorenko.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types alien.destructors
-alien.libraries alien.strings alien.syntax combinators
-gobject-introspection gobject-introspection.standard-types
-io.encodings.utf8 kernel system vocabs.parser words ;
+USING: accessors alien alien.destructors alien.libraries
+alien.strings alien.syntax combinators io.encodings.utf8 kernel
+gobject.ffi gobject-introspection gobject-introspection.standard-types
+system ;
IN: glib.ffi
LIBRARY: glib
} cond
>>
-
-TYPEDEF: char gchar
-TYPEDEF: uchar guchar
-TYPEDEF: short gshort
-TYPEDEF: ushort gushort
-TYPEDEF: long glong
-TYPEDEF: ulong gulong
-TYPEDEF: int gint
-TYPEDEF: uint guint
-
-<<
-int c-type clone
- [ >c-bool ] >>unboxer-quot
- [ c-bool> ] >>boxer-quot
- object >>boxed-class
-"gboolean" current-vocab create typedef
->>
-
-TYPEDEF: char gint8
-TYPEDEF: uchar guint8
-TYPEDEF: short gint16
-TYPEDEF: ushort guint16
-TYPEDEF: int gint32
-TYPEDEF: uint guint32
-TYPEDEF: longlong gint64
-TYPEDEF: ulonglong guint64
-
-TYPEDEF: float gfloat
-TYPEDEF: double gdouble
-
-TYPEDEF: long ssize_t
-TYPEDEF: long time_t
-TYPEDEF: size_t gsize
-TYPEDEF: ssize_t gssize
-TYPEDEF: size_t GType
-
-TYPEDEF: void* gpointer
-TYPEDEF: void* gconstpointer
-
-TYPEDEF: guint8 GDateDay
-TYPEDEF: guint16 GDateYear
-TYPEDEF: gint GPid
-TYPEDEF: guint32 GQuark
-TYPEDEF: gint32 GTime
-TYPEDEF: glong gintptr
-TYPEDEF: gint64 goffset
-TYPEDEF: gulong guintptr
-TYPEDEF: guint32 gunichar
-TYPEDEF: guint16 gunichar2
-
-TYPEDEF: gpointer pointer
-
-REPLACE-C-TYPE: long\sdouble double
-REPLACE-C-TYPE: any gpointer
-
-IMPLEMENT-STRUCTS: GError GPollFD GSource GSourceFuncs ;
+IMPLEMENT-STRUCTS: GPollFD GSource GSourceFuncs ;
CONSTANT: G_MININT8 HEX: -80
CONSTANT: G_MAXINT8 HEX: 7f
} cond
>>
-IMPLEMENT-STRUCTS: GValue GParamSpecVariant ;
+IMPLEMENT-STRUCTS: GError GValue GParamSpecVariant ;
GIR: vocab:gobject/GObject-2.0.gir
+++ /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
-Slava Pestov
\ No newline at end of file
+++ /dev/null
-USING: images accessors kernel tools.test literals math.ranges
-byte-arrays ;
-IN: images.tesselation
-
-! Check an invariant we depend on
-[ t ] [
- <image> B{ 1 2 3 } >>bitmap dup clone [ bitmap>> ] bi@ eq?
-] unit-test
-
-[
- {
- {
- T{ image f { 2 2 } L ubyte-components f f B{ 1 2 5 6 } }
- T{ image f { 2 2 } L ubyte-components f f B{ 3 4 7 8 } }
- }
- {
- T{ image f { 2 2 } L ubyte-components f f B{ 9 10 13 14 } }
- T{ image f { 2 2 } L ubyte-components f f B{ 11 12 15 16 } }
- }
- }
-] [
- <image>
- 1 16 [a,b] >byte-array >>bitmap
- { 4 4 } >>dim
- L >>component-order
- ubyte-components >>component-type
- { 2 2 } tesselate
-] unit-test
-
-[
- {
- {
- T{ image f { 2 2 } L ubyte-components f f B{ 1 2 4 5 } }
- T{ image f { 1 2 } L ubyte-components f f B{ 3 6 } }
- }
- {
- T{ image f { 2 1 } L ubyte-components f f B{ 7 8 } }
- T{ image f { 1 1 } L ubyte-components f f B{ 9 } }
- }
- }
-] [
- <image>
- 1 9 [a,b] >byte-array >>bitmap
- { 3 3 } >>dim
- L >>component-order
- ubyte-components >>component-type
- { 2 2 } tesselate
-] unit-test
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: sequences kernel math grouping fry columns locals accessors
-images math.vectors arrays ;
-IN: images.tesselation
-
-: group-rows ( bitmap bitmap-dim -- rows )
- first <sliced-groups> ; inline
-
-: tesselate-rows ( bitmap-rows tess-dim -- bitmaps )
- second <sliced-groups> ; inline
-
-: tesselate-columns ( bitmap-rows tess-dim -- bitmaps )
- first '[ _ <sliced-groups> ] map flip ; inline
-
-: tesselate-bitmap ( bitmap bitmap-dim tess-dim -- bitmap-grid )
- [ group-rows ] dip
- [ tesselate-rows ] keep
- '[ _ tesselate-columns ] map ;
-
-: tile-width ( tile-bitmap original-image -- width )
- [ first length ] [ bytes-per-pixel ] bi* /i ;
-
-: <tile-image> ( tile-bitmap original-image -- tile-image )
- clone
- swap
- [ concat >>bitmap ]
- [ [ over tile-width ] [ length ] bi 2array >>dim ] bi ;
-
-:: tesselate ( image tess-dim -- image-grid )
- image bytes-per-pixel :> bpp
- image dim>> { bpp 1 } v* :> image-dim'
- tess-dim { bpp 1 } v* :> tess-dim'
- image bitmap>> image-dim' tess-dim' tesselate-bitmap
- [ [ image <tile-image> ] map ] map ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+USING: images accessors kernel tools.test literals math.ranges
+byte-arrays ;
+IN: images.tessellation
+
+! Check an invariant we depend on
+[ t ] [
+ <image> B{ 1 2 3 } >>bitmap dup clone [ bitmap>> ] bi@ eq?
+] unit-test
+
+[
+ {
+ {
+ T{ image f { 2 2 } L ubyte-components f f B{ 1 2 5 6 } }
+ T{ image f { 2 2 } L ubyte-components f f B{ 3 4 7 8 } }
+ }
+ {
+ T{ image f { 2 2 } L ubyte-components f f B{ 9 10 13 14 } }
+ T{ image f { 2 2 } L ubyte-components f f B{ 11 12 15 16 } }
+ }
+ }
+] [
+ <image>
+ 1 16 [a,b] >byte-array >>bitmap
+ { 4 4 } >>dim
+ L >>component-order
+ ubyte-components >>component-type
+ { 2 2 } tesselate
+] unit-test
+
+[
+ {
+ {
+ T{ image f { 2 2 } L ubyte-components f f B{ 1 2 4 5 } }
+ T{ image f { 1 2 } L ubyte-components f f B{ 3 6 } }
+ }
+ {
+ T{ image f { 2 1 } L ubyte-components f f B{ 7 8 } }
+ T{ image f { 1 1 } L ubyte-components f f B{ 9 } }
+ }
+ }
+] [
+ <image>
+ 1 9 [a,b] >byte-array >>bitmap
+ { 3 3 } >>dim
+ L >>component-order
+ ubyte-components >>component-type
+ { 2 2 } tesselate
+] unit-test
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences kernel math grouping fry columns locals accessors
+images math.vectors arrays ;
+IN: images.tessellation
+
+: group-rows ( bitmap bitmap-dim -- rows )
+ first <sliced-groups> ; inline
+
+: tesselate-rows ( bitmap-rows tess-dim -- bitmaps )
+ second <sliced-groups> ; inline
+
+: tesselate-columns ( bitmap-rows tess-dim -- bitmaps )
+ first '[ _ <sliced-groups> ] map flip ; inline
+
+: tesselate-bitmap ( bitmap bitmap-dim tess-dim -- bitmap-grid )
+ [ group-rows ] dip
+ [ tesselate-rows ] keep
+ '[ _ tesselate-columns ] map ;
+
+: tile-width ( tile-bitmap original-image -- width )
+ [ first length ] [ bytes-per-pixel ] bi* /i ;
+
+: <tile-image> ( tile-bitmap original-image -- tile-image )
+ clone
+ swap
+ [ concat >>bitmap ]
+ [ [ over tile-width ] [ length ] bi 2array >>dim ] bi ;
+
+:: tesselate ( image tess-dim -- image-grid )
+ image bytes-per-pixel :> bpp
+ image dim>> { bpp 1 } v* :> image-dim'
+ tess-dim { bpp 1 } v* :> tess-dim'
+ image bitmap>> image-dim' tess-dim' tesselate-bitmap
+ [ [ image <tile-image> ] map ] map ;
+++ /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
[ t ] [ "\\\\?\\c:" root-directory? ] unit-test
[ f ] [ "\\\\?\\c:\\bar" root-directory? ] unit-test
+[ "\\\\a\\b\\c\\foo.xls" ] [ "//a/b/c/foo.xls" normalize-path ] unit-test
+[ "\\\\a\\b\\c\\foo.xls" ] [ "\\\\a\\b\\c\\foo.xls" normalize-path ] unit-test
+
[ "\\foo\\bar" ] [ "/foo/bar" normalize-path ":" split1 nip ] unit-test
[ "\\\\?\\C:\\builds\\factor\\log.txt" ] [
TR: normalize-separators "/" "\\" ;
+<PRIVATE
+
+: unc-path? ( string -- ? )
+ [ "//" head? ] [ "\\\\" head? ] bi or ;
+
+PRIVATE>
+
M: winnt normalize-path ( string -- string' )
- absolute-path
- normalize-separators
- prepend-prefix ;
+ dup unc-path? [
+ normalize-separators
+ ] [
+ absolute-path
+ normalize-separators
+ prepend-prefix
+ ] if ;
M: winnt CreateFile-flags ( DWORD -- DWORD )
FILE_FLAG_OVERLAPPED bitor ;
USING: nibble-arrays tools.test sequences kernel math ;
IN: nibble-arrays.tests
+[ -1 <nibble-array> ] [ T{ bad-array-length f -1 } = ] must-fail-with
+
[ t ] [ 16 iota dup >nibble-array sequence= ] unit-test
[ N{ 4 2 1 3 } ] [ N{ 3 1 2 4 } reverse ] unit-test
[ N{ 1 4 9 0 9 4 } ] [ N{ 1 2 3 4 5 6 } [ sq ] map ] unit-test
PRIVATE>
+ERROR: bad-array-length n ;
+
: <nibble-array> ( n -- nibble-array )
+ dup 0 < [ bad-array-length ] when
dup nibbles>bytes <byte-array> nibble-array boa ; inline
M: nibble-array length length>> ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.data assocs cache colors.constants
destructors kernel opengl opengl.gl opengl.capabilities
-combinators images images.tesselation grouping sequences math
+combinators images images.tessellation grouping sequences math
math.vectors generalizations fry arrays namespaces system locals
literals specialized-arrays ;
FROM: alien.c-types => int float ;
! Copyright (C) 2011 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel sequences ;
+USING: alien.c-types help.markup help.syntax kernel quotations
+sequences strings ;
IN: tools.coverage
HELP: <coverage>
{ "executed?" boolean }
{ "coverage" coverage }
}
-{ $description "Makes a coverage tuple. Users should not call this directly." } ;
+{ $description "Makes a coverage tuple. Users should not call this directly." } ;
+
+HELP: each-word
+{ $values
+ { "string" string } { "quot" quotation }
+}
+{ $description "Calls a quotation on every word in the vocabulary and its private vocabulary, if there is one." } ;
+
+HELP: map-words
+{ $values
+ { "string" string } { "quot" quotation }
+ { "sequence" sequence }
+}
+{ $description "Calls a quotation on every word in the vocabulary and its private vocabulary, if there is one, and collects the results." } ;
HELP: coverage
{ $values
{ $values
{ "object" object }
}
-{ $description "Deactivates the coverage tool on a word or vocabulary." } ;
+{ $description "Deactivates the coverage tool on a word or vocabulary and its private vocabulary." } ;
HELP: coverage-on
{ $values
{ "object" object }
}
-{ $description "Activates the coverage tool on a word or vocabulary." } ;
+{ $description "Activates the coverage tool on a word or vocabulary and its private vocabulary." } ;
+
+HELP: toggle-coverage
+{ $values
+ { "object" object }
+}
+{ $description "Toggles whether the coverage tool is active on a word or vocabulary and its private vocabulary." } ;
HELP: coverage.
{ $values
}
{ $description "Calls the coverage word on all the words in a vocabalary or on a single word and prints out a report." } ;
-ARTICLE: "tools.coverage" "tools.coverage"
+HELP: %coverage
+{ $values
+ { "string" string }
+ { "x" double }
+}
+{ $description "Returns a fraction representing the number of quotations called compared to the number of quotations that exist in a vocabulary or word." } ;
+
+ARTICLE: "tools.coverage" "Coverage tool"
"The " { $vocab-link "tools.coverage" } " vocabulary is a tool for testing code coverage. The implementation uses " { $vocab-link "tools.annotations" } " to place a coverage object at the beginning of every quotation. When the quotation executes, a slot on the coverage object is set to true. By examining the coverage objects after running the code for some time, one can see which of the quotations did not execute and write more tests or refactor the code." $nl
"Enabling/disabling coverage:"
-{ $subsections coverage-on coverage-off }
+{ $subsections coverage-on coverage-off toggle-coverage }
"Examining coverage data:"
-{ $subsections coverage coverage. } ;
+{ $subsections coverage coverage. %coverage }
+"Combinators for iterating over words in a vocabulary:"
+{ $subsections each-word map-words } ;
ABOUT: "tools.coverage"
! Copyright (C) 2011 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs fry kernel quotations sequences strings
-tools.annotations vocabs words prettyprint io ;
+USING: accessors assocs fry io kernel math prettyprint
+quotations sequences sequences.deep splitting strings
+tools.annotations vocabs words arrays words.symbol
+combinators.short-circuit ;
IN: tools.coverage
TUPLE: coverage < identity-tuple executed? ;
GENERIC: coverage-off ( object -- )
+<PRIVATE
+
+: private-vocab-name ( string -- string' )
+ ".private" ?tail drop ".private" append ;
+
+: coverage-words ( string -- words )
+ words [ { [ primitive? not ] [ symbol? not ] } 1&& ] filter ;
+
+PRIVATE>
+
+: each-word ( string quot -- )
+ over ".private" tail? [
+ [ coverage-words ] dip each
+ ] [
+ [ [ private-vocab-name coverage-words ] dip each ]
+ [ [ coverage-words ] dip each ] 2bi
+ ] if ; inline
+
+: map-words ( string quot -- sequence )
+ over ".private" tail? [
+ [ coverage-words ] dip map
+ ] [
+ [ [ private-vocab-name coverage-words ] dip map ]
+ [ [ coverage-words ] dip map ] 2bi append
+ ] if ; inline
+
M: string coverage-on
- words [ coverage-on ] each ;
+ [ coverage-on ] each-word ;
M: string coverage-off ( vocabulary -- )
- words [ coverage-off ] each ;
+ [ coverage-off ] each-word ;
M: word coverage-on ( word -- )
H{ } clone [ "coverage" set-word-prop ] 2keep
'[
\ coverage new [ _ set-at ] 2keep
- '[ _ t >>executed? drop ] [ ] surround
+ '[ _ t >>executed? drop ] prepend
] deep-annotate ;
M: word coverage-off ( word -- )
[ reset ] [ f "coverage" set-word-prop ] bi ;
+GENERIC: toggle-coverage ( object -- )
+
+M: string toggle-coverage
+ [ toggle-coverage ] each-word ;
+
+M: word toggle-coverage
+ dup "coverage" word-prop [
+ coverage-off
+ ] [
+ coverage-on
+ ] if ;
+
GENERIC: coverage ( object -- seq )
M: string coverage
- words [ dup coverage ] { } map>assoc ;
+ [ dup coverage 2array ] map-words ;
M: word coverage ( word -- seq )
"coverage" word-prop >alist
GENERIC: coverage. ( object -- )
M: string coverage.
- words [ coverage. ] each ;
+ [ coverage. ] each-word ;
M: word coverage.
dup coverage [
drop
] [
[ name>> ":" append print ]
- [ [ bl bl bl bl . ] each ] bi*
+ [ [ " " write . ] each ] bi*
] if-empty ;
+
+<PRIVATE
+
+GENERIC: count-callables ( object -- n )
+
+M: string count-callables
+ [ count-callables ] map-words sum ;
+
+M: word count-callables
+ "coverage" word-prop assoc-size ;
+
+PRIVATE>
+
+: %coverage ( string -- x )
+ [ coverage values concat length ]
+ [ count-callables ] bi [ swap - ] keep /f ; inline
{ $ GDK_SCROLL_RIGHT { 1 0 } }
} at ;
-: mouse-event>gesture ( event -- modifiers button loc )
- [ event-modifiers ] [ button>> ] [ event-loc ] tri ;
-
: on-motion ( win event user-data -- ? )
drop swap
[ event-loc ] dip window
:: on-button-press ( win event user-data -- ? )
win window :> world
- event mouse-event>gesture :> ( modifiers button loc )
- button {
- { 8 [ ] }
- { 9 [ ] }
- [ modifiers swap <button-down> loc world
- send-button-down ]
- } case t ;
+ event type>> GDK_BUTTON_PRESS = [
+ event button>> {
+ { 8 [ ] }
+ { 9 [ ] }
+ [
+ event event-modifiers swap <button-down>
+ event event-loc
+ world
+ send-button-down
+ ]
+ } case
+ ] when t ;
:: on-button-release ( win event user-data -- ? )
win window :> world
- event mouse-event>gesture :> ( modifiers button loc )
- button {
- { 8 [ world left-action send-action ] }
- { 9 [ world right-action send-action ] }
- [ modifiers swap <button-up> loc world
- send-button-up ]
- } case t ;
+ event type>> GDK_BUTTON_RELEASE = [
+ event button>> {
+ { 8 [ world left-action send-action ] }
+ { 9 [ world right-action send-action ] }
+ [
+ event event-modifiers swap <button-up>
+ event event-loc
+ world
+ send-button-up
+ ]
+ } case
+ ] when t ;
: on-scroll ( win event user-data -- ? )
drop swap [
: key-event>gesture ( event -- mods sym/f action? )
[ event-modifiers ] [ key-sym ] bi ;
-
+
: on-key-press ( win event user-data -- ? )
drop swap [ key-event>gesture <key-down> ] [ window ] bi*
propagate-key-gesture t ;
:: configure-im ( win im -- )
im win gtk_widget_get_window gtk_im_context_set_client_window
im f gtk_im_context_set_use_preedit
-
+
im "commit" [ on-commit yield ]
GtkIMContext:commit win connect-signal-with-data
im "retrieve-surrounding" [ on-retrieve-surrounding yield ]
{ normal-title-bar $ GDK_DECOR_TITLE }
{ textured-background 0 }
}
-
+
CONSTANT: window-controls>func-flags
H{
{ close-button $ GDK_FUNC_CLOSE }
win im <window-handle> world handle<<
world win register-window
-
+
win world [ window-loc>> auto-position ]
[ dim>> first2 gtk_window_set_default_size ] 2bi
win "factor" "Factor" [ utf8 string>alien ] bi@
gtk_window_set_wmclass
-
+
world configure-gl
win gtk_widget_realize
win world window-controls>> configure-window-controls
-
+
win im configure-im
win connect-user-input-signals
win connect-win-state-signals
M: gtk-ui-backend (fullscreen?)
handle>> fullscreen?>> ;
-
+
M: gtk-ui-backend raise-window*
handle>> window>> gtk_window_present ;
: show-glass ( owner child visible-rect -- )
<glass>
- dup gadget-child hand-clicked set
+ dup gadget-child hand-clicked set-global
dup owner>> find-world add-glass ;
\ glass H{
: row-action ( table -- )
dup selected-row
- [ swap [ action>> call( value -- ) ] [ dup hook>> call( table -- ) ] bi ]
+ [ swap [ dup hook>> call( table -- ) ] [ action>> call( value -- ) ] bi ]
[ 2drop ]
if ;
cached-lines get purge-cache ;
M: core-text-renderer string>image ( font string -- image loc )
- cached-line [ image>> ] [ loc>> ] bi ;
+ cached-line [ line>image ] [ loc>> ] bi ;
M: core-text-renderer x>offset ( x font string -- n )
[ 2drop 0 ] [
[ cached-line metrics>> ]
if-empty ;
-core-text-renderer font-renderer set-global
\ No newline at end of file
+core-text-renderer font-renderer set-global
HELP: filter-moved
{ $values { "assoc1" assoc } { "assoc2" assoc } { "seq" "an sequence of definitions" } }
-{ $description "Removes all definitions from " { $snippet "assoc2" } " which are in " { $snippet "assoc1" } " or are are no longer present in the current " { $link file } "." } ;
+{ $description "Removes all definitions from " { $snippet "assoc2" } " which are in " { $snippet "assoc1" } " or are no longer present in the current " { $link file } "." } ;
HELP: forget-smudged
{ $description "Forgets removed definitions." } ;
M: set intersects?
small/large sequence/tester any? ;
+<PRIVATE
+
+: (subset?) ( set1 set2 -- ? )
+ sequence/tester all? ; inline
+
+PRIVATE>
+
M: set subset?
- sequence/tester all? ;
+ 2dup [ cardinality ] bi@ > [ 2drop f ] [ (subset?) ] if ;
M: set set=
- 2dup [ cardinality ] bi@ eq? [ subset? ] [ 2drop f ] if ;
+ 2dup [ cardinality ] bi@ eq? [ (subset?) ] [ 2drop f ] if ;
M: set fast-set ;
empty? ; inline
M: sequence cardinality
- length ;
+ pruned length ;
: combine ( sets -- set )
[ f ]
HELP: supported-engines
{ $values
- { "value" array }
+ { "seq" array }
}
{ $description "An " { $link array } " of " { $link string } "s representing all valid " { $emphasis "layout engines" } ". For example, the " { $emphasis "dot" } " engine is typically included in a Graphviz installation, so " { $snippet "\"dot\"" } " will be an element of " { $link supported-engines } ". See " { $url "http://graphviz.org/Documentation.php" } " for more details." }
{ $notes "This constant's definition is determined at parse-time by asking the system's Graphviz installation what engines are supported." }
HELP: supported-formats
{ $values
- { "value" array }
+ { "seq" array }
}
{ $description "An " { $link array } " of " { $link string } "s representing all valid " { $emphasis "layout formats" } ". For example, Graphviz can typically render using the Postscript format, in which case " { $snippet "\"ps\"" } " will be an element of " { $link supported-formats } ". See " { $url "http://graphviz.org/Documentation.php" } " for more details." }
{ $notes "This constant's definition is determined at parse-time by asking the system's Graphviz installation what formats are supported."
USING: accessors alien alien.c-types alien.destructors
alien.libraries alien.syntax combinators debugger destructors
fry io kernel literals math prettyprint sequences splitting
-system words.constant
-graphviz
-;
+system memoize graphviz ;
IN: graphviz.ffi
<<
LIBRARY: libgvc
! Graphviz contexts
-! This must be wrapped in << >> so that GVC_t*, gvContext, and
-! &gvFreeContext can be used to compute the supported-engines
-! and supported-formats constants below.
-<<
C-TYPE: GVC_t
FUNCTION: GVC_t* gvContext ( ) ;
int-gvFreeContext dup zero? [ drop ] [ ffi-errors ] if ;
DESTRUCTOR: gvFreeContext
->>
! Layout
! Supported layout engines (dot, neato, etc.) and output
! formats (png, jpg, etc.)
-
-<<
<PRIVATE
ENUM: api_t
] with-destructors ;
PRIVATE>
->>
-CONSTANT: supported-engines $[ API_layout plugin-list ]
-CONSTANT: supported-formats $[ API_device plugin-list ]
+MEMO: supported-engines ( -- seq ) API_layout plugin-list ;
+MEMO: supported-formats ( -- seq ) API_device plugin-list ;
! Copyright (C) 2011 Alex Vondrak.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators continuations destructors
-images.viewer io.backend io.files.unique kernel locals
-namespaces parser sequences summary unicode.case words
-graphviz.ffi
-graphviz.builder
-;
+USING: accessors combinators compiler.units continuations
+destructors images.viewer io.backend io.files.unique kernel
+locals namespaces parser sequences summary unicode.case words
+graphviz.ffi graphviz.builder ;
IN: graphviz.render
SYMBOL: default-layout
: preview-window ( graph -- )
(preview) image-window ; inline
-<<
-
<PRIVATE
: define-graphviz-by-engine ( -K -- )
- [ create-in dup make-inline ]
+ [ "graphviz.render" create dup make-inline ]
[ [ graphviz ] curry ] bi
(( graph -O -T -- ))
define-declared ;
: define-graphviz-by-format ( -T -- )
[
dup supported-engines member? [ "-file" append ] when
- create-in dup make-inline
+ "graphviz.render" create dup make-inline
]
[ [ graphviz* ] curry ] bi
(( graph -O -- ))
PRIVATE>
-supported-engines [ define-graphviz-by-engine ] each
-supported-formats [ define-graphviz-by-format ] each
-
->>
+[
+ supported-engines [ define-graphviz-by-engine ] each
+ supported-formats [ define-graphviz-by-format ] each
+] with-compilation-unit
--- /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
+Maximilian Lupke
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2010 Maximilian Lupke.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays help.markup help.syntax kernel strings ;
+IN: semantic-versioning
+
+HELP: split-version
+{ $values
+ { "string" string }
+ { "array" array }
+}
+{ $description "Splits the version string into a sequnece of major version, minor version, patch level and an alphanumeric identifier if given. See " { $url "http://semver.org/" } " for a detailed description." } ;
+
+HELP: version<
+{ $values
+ { "version1" string } { "version2" string }
+ { "?" boolean }
+} ;
+
+HELP: version<=
+{ $values
+ { "version1" string } { "version2" string }
+ { "?" boolean }
+} ;
+
+HELP: version<=>
+{ $values
+ { "version1" string } { "version2" string }
+ { "<=>" string }
+} ;
+
+HELP: version=
+{ $values
+ { "version1" string } { "version2" string }
+ { "?" boolean }
+} ;
+
+HELP: version>
+{ $values
+ { "version1" string } { "version2" string }
+ { "?" boolean }
+} ;
+
+HELP: version>=
+{ $values
+ { "version1" string } { "version2" string }
+ { "?" boolean }
+} ;
+
+ARTICLE: { "Versioning" "Semantic Versioning" } "Semantic Versioning"
+{ $vocab-link "semantic-versioning" }
+$nl
+{ "See " { $url "http://semver.org/" } " for a detailed description of semantic versioning." }
+;
+
+ABOUT: { "Versioning" "Semantic Versioning" }
--- /dev/null
+USING: math.order semantic-versioning tools.test ;
+IN: semantic-versioning.tests
+
+[ { 1 0 0 "dev1" } ] [ "1.0.0dev1" split-version ] unit-test
+[ { 1 2 3 } ] [ "1.2.3" split-version ] unit-test
+
+[ +gt+ ] [ "1.2.0dev1" "0.12.1dev2" version<=> ] unit-test
+[ +eq+ ] [ "2.0.0rc1" "2.0.0rc1" version<=> ] unit-test
+[ +lt+ ] [ "1.0.0rc1" "1.0.0" version<=> ] unit-test
+[ +lt+ ] [ "1.0.0rc1" "1.0.0rc2" version<=> ] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2010 Maximilian Lupke.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays ascii kernel math.order math.parser sequences splitting
+;
+IN: semantic-versioning
+
+: split-version ( string -- array )
+ "." split first3 dup [ digit? not ] find
+ [ cut [ [ string>number ] tri@ ] dip 4array ]
+ [ drop [ string>number ] tri@ 3array ]
+ if ;
+
+: version<=> ( version1 version2 -- <=> )
+ [ split-version ] bi@ drop-prefix
+ 2dup [ length 0 = ] either?
+ [ [ length ] bi@ >=< ] [ [ first ] bi@ <=> ] if ;
+
+: version< ( version1 version2 -- ? )
+ version<=> +lt+ = ;
+
+: version<= ( version1 version2 -- ? )
+ version<=> [ +lt+ = ] [ +eq+ = ] either? ;
+
+: version= ( version1 version2 -- ? )
+ version<=> +eq+ = ;
+
+: version>= ( version1 version2 -- ? )
+ version<=> [ +gt+ = ] [ +eq+ = ] either? ;
+
+: version> ( version1 version2 -- ? )
+ version<=> +gt+ = ;
projects / factor.git / commitdiff