Merge branch 'master' of git://factorcode.org/git/factor
Joe Groff
commit
85a3787622
|
|
@ -1,9 +1,11 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors grouping sequences combinators ;
|
||||
USING: kernel accessors grouping sequences combinators
|
||||
math specialized-arrays.direct.uint byte-arrays ;
|
||||
IN: images
|
||||
|
||||
SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ;
|
||||
SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
|
||||
R16G16B16 R32G32B32 ;
|
||||
|
||||
TUPLE: image dim component-order byte-order bitmap ;
|
||||
|
||||
|
|
@ -11,22 +13,32 @@ TUPLE: image dim component-order byte-order bitmap ;
|
|||
|
||||
GENERIC: load-image* ( path tuple -- image )
|
||||
|
||||
: add-dummy-alpha ( seq -- seq' )
|
||||
3 <sliced-groups>
|
||||
[ 255 suffix ] map concat ;
|
||||
|
||||
: normalize-component-order ( image -- image )
|
||||
dup component-order>>
|
||||
{
|
||||
{ RGBA [ ] }
|
||||
{ R32G32B32 [
|
||||
[
|
||||
dup length 4 / <direct-uint-array>
|
||||
[ bits>float 255.0 * >integer ] map
|
||||
>byte-array add-dummy-alpha
|
||||
] change-bitmap
|
||||
] }
|
||||
{ BGRA [
|
||||
[
|
||||
4 <sliced-groups> dup [ [ 0 3 ] dip <slice> reverse-here ] each
|
||||
] change-bitmap
|
||||
] }
|
||||
{ RGB [
|
||||
[ 3 <sliced-groups> [ 255 suffix ] map concat ] change-bitmap
|
||||
] }
|
||||
{ RGB [ [ add-dummy-alpha ] change-bitmap ] }
|
||||
{ BGR [
|
||||
[
|
||||
3 <sliced-groups> dup [ [ 0 3 ] dip <slice> reverse-here ] each
|
||||
[ 255 suffix ] map concat
|
||||
3 <sliced-groups>
|
||||
[ [ [ 0 3 ] dip <slice> reverse-here ] each ]
|
||||
[ add-dummy-alpha ] bi
|
||||
] change-bitmap
|
||||
] }
|
||||
} case
|
||||
|
|
@ -37,5 +49,6 @@ GENERIC: normalize-scan-line-order ( image -- image )
|
|||
M: image normalize-scan-line-order ;
|
||||
|
||||
: normalize-image ( image -- image )
|
||||
[ >byte-array ] change-bitmap
|
||||
normalize-component-order
|
||||
normalize-scan-line-order ;
|
||||
|
|
|
|||
|
|
@ -10,6 +10,7 @@ ERROR: unknown-image-extension extension ;
|
|||
: image-class ( path -- class )
|
||||
file-extension >lower {
|
||||
{ "bmp" [ bitmap-image ] }
|
||||
{ "tif" [ tiff-image ] }
|
||||
{ "tiff" [ tiff-image ] }
|
||||
[ unknown-image-extension ]
|
||||
} case ;
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: accessors combinators io io.encodings.binary io.files kernel
|
||||
pack endian constructors sequences arrays math.order math.parser
|
||||
prettyprint classes io.binary assocs math math.bitwise byte-arrays
|
||||
grouping images compression.lzw fry ;
|
||||
grouping images compression.lzw fry strings ;
|
||||
IN: images.tiff
|
||||
|
||||
TUPLE: tiff-image < image ;
|
||||
|
|
@ -115,8 +115,9 @@ ERROR: bad-extra-samples n ;
|
|||
|
||||
SINGLETONS: image-length image-width x-resolution y-resolution
|
||||
rows-per-strip strip-offsets strip-byte-counts bits-per-sample
|
||||
samples-per-pixel new-subfile-type orientation
|
||||
unhandled-ifd-entry ;
|
||||
samples-per-pixel new-subfile-type orientation software
|
||||
date-time photoshop exif-ifd sub-ifd inter-color-profile
|
||||
xmp iptc unhandled-ifd-entry ;
|
||||
|
||||
ERROR: bad-tiff-magic bytes ;
|
||||
: tiff-endianness ( byte-array -- ? )
|
||||
|
|
@ -185,6 +186,7 @@ ERROR: unknown-ifd-type n ;
|
|||
{ 10 [ 8 * ] }
|
||||
{ 11 [ 4 * ] }
|
||||
{ 12 [ 8 * ] }
|
||||
{ 13 [ 4 * ] }
|
||||
[ unknown-ifd-type ]
|
||||
} case ;
|
||||
|
||||
|
|
@ -200,6 +202,7 @@ ERROR: bad-small-ifd-type n ;
|
|||
{ 8 [ 2 head endian> 16 >signed ] }
|
||||
{ 9 [ endian> 32 >signed ] }
|
||||
{ 11 [ endian> bits>float ] }
|
||||
{ 13 [ endian> 32 >signed ] }
|
||||
[ bad-small-ifd-type ]
|
||||
} case ;
|
||||
|
||||
|
|
@ -246,10 +249,18 @@ ERROR: bad-small-ifd-type n ;
|
|||
{ 283 [ y-resolution ] }
|
||||
{ 284 [ planar-configuration ] }
|
||||
{ 296 [ lookup-resolution-unit resolution-unit ] }
|
||||
{ 305 [ >string software ] }
|
||||
{ 306 [ >string date-time ] }
|
||||
{ 317 [ lookup-predictor predictor ] }
|
||||
{ 330 [ sub-ifd ] }
|
||||
{ 338 [ lookup-extra-samples extra-samples ] }
|
||||
{ 339 [ lookup-sample-format sample-format ] }
|
||||
[ nip unhandled-ifd-entry ]
|
||||
{ 700 [ >string xmp ] }
|
||||
{ 34377 [ photoshop ] }
|
||||
{ 34665 [ exif-ifd ] }
|
||||
{ 33723 [ iptc ] }
|
||||
{ 34675 [ inter-color-profile ] }
|
||||
[ nip unhandled-ifd-entry swap ]
|
||||
} case ;
|
||||
|
||||
: process-ifd ( ifd -- ifd )
|
||||
|
|
@ -276,9 +287,11 @@ ERROR: unhandled-compression compression ;
|
|||
ERROR: unknown-component-order ifd ;
|
||||
|
||||
: ifd-component-order ( ifd -- byte-order )
|
||||
bits-per-sample find-tag sum {
|
||||
{ 32 [ RGBA ] }
|
||||
{ 24 [ RGB ] }
|
||||
bits-per-sample find-tag {
|
||||
{ { 32 32 32 } [ R32G32B32 ] }
|
||||
{ { 16 16 16 } [ R16G16B16 ] }
|
||||
{ { 8 8 8 8 } [ RGBA ] }
|
||||
{ { 8 8 8 } [ RGB ] }
|
||||
[ unknown-component-order ]
|
||||
} case ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays io io.streams.string kernel math math.parser
|
||||
namespaces sequences splitting grouping strings ascii byte-arrays ;
|
||||
namespaces sequences splitting grouping strings ascii
|
||||
byte-arrays byte-vectors ;
|
||||
IN: tools.hexdump
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -26,13 +27,17 @@ IN: tools.hexdump
|
|||
: write-hex-line ( bytes lineno -- )
|
||||
write-offset [ >hex-digits write ] [ >ascii write ] bi nl ;
|
||||
|
||||
: hexdump-bytes ( bytes -- )
|
||||
[ length write-header ]
|
||||
[ 16 <sliced-groups> [ write-hex-line ] each-index ] bi ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
GENERIC: hexdump. ( byte-array -- )
|
||||
|
||||
M: byte-array hexdump.
|
||||
[ length write-header ]
|
||||
[ 16 <sliced-groups> [ write-hex-line ] each-index ] bi ;
|
||||
M: byte-array hexdump. hexdump-bytes ;
|
||||
|
||||
M: byte-vector hexdump. hexdump-bytes ;
|
||||
|
||||
: hexdump ( byte-array -- str )
|
||||
[ hexdump. ] with-string-writer ;
|
||||
|
|
|
|||
|
|
@ -1 +0,0 @@
|
|||
Doug Coleman
|
||||
|
|
@ -1 +0,0 @@
|
|||
Doug Coleman
|
||||
|
|
@ -1,30 +0,0 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.syntax combinators system ;
|
||||
IN: zlib.ffi
|
||||
|
||||
<< "zlib" {
|
||||
{ [ os winnt? ] [ "zlib1.dll" ] }
|
||||
{ [ os macosx? ] [ "libz.dylib" ] }
|
||||
{ [ os unix? ] [ "libz.so" ] }
|
||||
} cond "cdecl" add-library >>
|
||||
|
||||
LIBRARY: zlib
|
||||
|
||||
CONSTANT: Z_OK 0
|
||||
CONSTANT: Z_STREAM_END 1
|
||||
CONSTANT: Z_NEED_DICT 2
|
||||
CONSTANT: Z_ERRNO -1
|
||||
CONSTANT: Z_STREAM_ERROR -2
|
||||
CONSTANT: Z_DATA_ERROR -3
|
||||
CONSTANT: Z_MEM_ERROR -4
|
||||
CONSTANT: Z_BUF_ERROR -5
|
||||
CONSTANT: Z_VERSION_ERROR -6
|
||||
|
||||
TYPEDEF: void Bytef
|
||||
TYPEDEF: ulong uLongf
|
||||
TYPEDEF: ulong uLong
|
||||
|
||||
FUNCTION: int compress ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen ) ;
|
||||
FUNCTION: int compress2 ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen, int level ) ;
|
||||
FUNCTION: int uncompress ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen ) ;
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel tools.test zlib classes ;
|
||||
IN: zlib.tests
|
||||
|
||||
: compress-me ( -- byte-array ) B{ 1 2 3 4 5 } ;
|
||||
|
||||
[ t ] [ compress-me [ compress uncompress ] keep = ] unit-test
|
||||
[ t ] [ compress-me compress compressed instance? ] unit-test
|
||||
|
|
@ -1,48 +0,0 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types alien.syntax byte-arrays combinators
|
||||
kernel math math.functions sequences system accessors
|
||||
libc ;
|
||||
QUALIFIED: zlib.ffi
|
||||
IN: zlib
|
||||
|
||||
TUPLE: compressed data length ;
|
||||
|
||||
: <compressed> ( data length -- compressed )
|
||||
compressed new
|
||||
swap >>length
|
||||
swap >>data ;
|
||||
|
||||
ERROR: zlib-failed n string ;
|
||||
|
||||
: zlib-error-message ( n -- * )
|
||||
dup zlib.ffi:Z_ERRNO = [
|
||||
drop errno "native libc error"
|
||||
] [
|
||||
dup {
|
||||
"no error" "libc_error"
|
||||
"stream error" "data error"
|
||||
"memory error" "buffer error" "zlib version error"
|
||||
} ?nth
|
||||
] if zlib-failed ;
|
||||
|
||||
: zlib-error ( n -- )
|
||||
dup zlib.ffi:Z_OK = [ drop ] [ dup zlib-error-message zlib-failed ] if ;
|
||||
|
||||
: compressed-size ( byte-array -- n )
|
||||
length 1001/1000 * ceiling 12 + ;
|
||||
|
||||
: compress ( byte-array -- compressed )
|
||||
[
|
||||
[ compressed-size <byte-array> dup length <ulong> ] keep [
|
||||
dup length zlib.ffi:compress zlib-error
|
||||
] 3keep drop *ulong head
|
||||
] keep length <compressed> ;
|
||||
|
||||
: uncompress ( compressed -- byte-array )
|
||||
[
|
||||
length>> [ <byte-array> ] keep <ulong> 2dup
|
||||
] [
|
||||
data>> dup length
|
||||
zlib.ffi:uncompress zlib-error
|
||||
] bi *ulong head ;
|
||||
|
|
@ -241,7 +241,7 @@ ARTICLE: "tuple-examples" "Tuple examples"
|
|||
}
|
||||
"An example of using a changer:"
|
||||
{ $code
|
||||
": positions"
|
||||
": positions ( -- seq )"
|
||||
" {"
|
||||
" \"junior programmer\""
|
||||
" \"senior programmer\""
|
||||
|
|
|
|||
Loading…
Reference in New Issue