Merge branch 'master' of git://factorcode.org/git/factor
commit
9fa3240b85
|
@ -0,0 +1,7 @@
|
||||||
|
! Copyright (C) 2009 Doug Coleman.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: arrays grouping sequences ;
|
||||||
|
IN: compression.run-length
|
||||||
|
|
||||||
|
: run-length-uncompress8 ( byte-array -- byte-array' )
|
||||||
|
2 group [ first2 <array> ] map concat ;
|
|
@ -1 +1,2 @@
|
||||||
Doug Coleman
|
Doug Coleman
|
||||||
|
Daniel Ehrenberg
|
||||||
|
|
|
@ -1,9 +1,10 @@
|
||||||
! Copyright (C) 2007, 2009 Doug Coleman.
|
! Copyright (C) 2007, 2009 Doug Coleman.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors alien alien.c-types arrays byte-arrays columns
|
USING: accessors alien alien.c-types arrays byte-arrays columns
|
||||||
combinators fry grouping io io.binary io.encodings.binary io.files
|
combinators compression.run-length endian fry grouping images
|
||||||
kernel macros math math.bitwise math.functions namespaces sequences
|
images.loader io io.binary io.encodings.binary io.files kernel
|
||||||
strings images endian summary locals ;
|
locals macros math math.bitwise math.functions namespaces
|
||||||
|
sequences strings summary ;
|
||||||
IN: images.bitmap
|
IN: images.bitmap
|
||||||
|
|
||||||
: assert-sequence= ( a b -- )
|
: assert-sequence= ( a b -- )
|
||||||
|
@ -21,7 +22,8 @@ TUPLE: bitmap-image < image ;
|
||||||
TUPLE: loading-bitmap
|
TUPLE: loading-bitmap
|
||||||
size reserved offset header-length width
|
size reserved offset header-length width
|
||||||
height planes bit-count compression size-image
|
height planes bit-count compression size-image
|
||||||
x-pels y-pels color-used color-important rgb-quads color-index ;
|
x-pels y-pels color-used color-important color-palette color-index
|
||||||
|
uncompressed-bytes ;
|
||||||
|
|
||||||
ERROR: bitmap-magic magic ;
|
ERROR: bitmap-magic magic ;
|
||||||
|
|
||||||
|
@ -31,7 +33,7 @@ M: bitmap-magic summary
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
: 8bit>buffer ( bitmap -- array )
|
: 8bit>buffer ( bitmap -- array )
|
||||||
[ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
|
[ color-palette>> 4 <sliced-groups> [ 3 head-slice ] map ]
|
||||||
[ color-index>> >array ] bi [ swap nth ] with map concat ;
|
[ color-index>> >array ] bi [ swap nth ] with map concat ;
|
||||||
|
|
||||||
ERROR: bmp-not-supported n ;
|
ERROR: bmp-not-supported n ;
|
||||||
|
@ -39,7 +41,7 @@ ERROR: bmp-not-supported n ;
|
||||||
: reverse-lines ( byte-array width -- byte-array )
|
: reverse-lines ( byte-array width -- byte-array )
|
||||||
<sliced-groups> <reversed> concat ; inline
|
<sliced-groups> <reversed> concat ; inline
|
||||||
|
|
||||||
: raw-bitmap>seq ( loading-bitmap -- array )
|
: bitmap>bytes ( loading-bitmap -- array )
|
||||||
dup bit-count>>
|
dup bit-count>>
|
||||||
{
|
{
|
||||||
{ 32 [ color-index>> ] }
|
{ 32 [ color-index>> ] }
|
||||||
|
@ -48,6 +50,21 @@ ERROR: bmp-not-supported n ;
|
||||||
[ bmp-not-supported ]
|
[ bmp-not-supported ]
|
||||||
} case >byte-array ;
|
} case >byte-array ;
|
||||||
|
|
||||||
|
ERROR: unsupported-bitmap-compression compression ;
|
||||||
|
|
||||||
|
: uncompress-bitmap ( loading-bitmap -- loading-bitmap' )
|
||||||
|
dup compression>> {
|
||||||
|
{ 0 [ ] }
|
||||||
|
{ 1 [ [ run-length-uncompress8 ] change-color-index ] }
|
||||||
|
{ 2 [ "run-length encoding 4" unsupported-bitmap-compression ] }
|
||||||
|
{ 3 [ "bitfields" unsupported-bitmap-compression ] }
|
||||||
|
{ 4 [ "jpeg" unsupported-bitmap-compression ] }
|
||||||
|
{ 5 [ "png" unsupported-bitmap-compression ] }
|
||||||
|
} case ;
|
||||||
|
|
||||||
|
: loading-bitmap>bytes ( loading-bitmap -- byte-array )
|
||||||
|
uncompress-bitmap bitmap>bytes ;
|
||||||
|
|
||||||
: parse-file-header ( loading-bitmap -- loading-bitmap )
|
: parse-file-header ( loading-bitmap -- loading-bitmap )
|
||||||
2 read "BM" assert-sequence=
|
2 read "BM" assert-sequence=
|
||||||
read4 >>size
|
read4 >>size
|
||||||
|
@ -67,7 +84,7 @@ ERROR: bmp-not-supported n ;
|
||||||
read4 >>color-used
|
read4 >>color-used
|
||||||
read4 >>color-important ;
|
read4 >>color-important ;
|
||||||
|
|
||||||
: rgb-quads-length ( loading-bitmap -- n )
|
: color-palette-length ( loading-bitmap -- n )
|
||||||
[ offset>> 14 - ] [ header-length>> ] bi - ;
|
[ offset>> 14 - ] [ header-length>> ] bi - ;
|
||||||
|
|
||||||
: color-index-length ( loading-bitmap -- n )
|
: color-index-length ( loading-bitmap -- n )
|
||||||
|
@ -98,11 +115,11 @@ ERROR: bmp-not-supported n ;
|
||||||
] when ;
|
] when ;
|
||||||
|
|
||||||
: parse-bitmap ( loading-bitmap -- loading-bitmap )
|
: parse-bitmap ( loading-bitmap -- loading-bitmap )
|
||||||
dup rgb-quads-length read >>rgb-quads
|
dup color-palette-length read >>color-palette
|
||||||
dup color-index-length read >>color-index
|
dup color-index-length read >>color-index
|
||||||
fixup-color-index ;
|
fixup-color-index ;
|
||||||
|
|
||||||
: load-bitmap-data ( path -- loading-bitmap )
|
: load-bitmap ( path -- loading-bitmap )
|
||||||
binary [
|
binary [
|
||||||
loading-bitmap new
|
loading-bitmap new
|
||||||
parse-file-header parse-bitmap-header parse-bitmap
|
parse-file-header parse-bitmap-header parse-bitmap
|
||||||
|
@ -120,14 +137,16 @@ ERROR: unknown-component-order bitmap ;
|
||||||
|
|
||||||
: loading-bitmap>bitmap-image ( bitmap-image loading-bitmap -- bitmap-image )
|
: loading-bitmap>bitmap-image ( bitmap-image loading-bitmap -- bitmap-image )
|
||||||
{
|
{
|
||||||
[ raw-bitmap>seq >>bitmap ]
|
[ loading-bitmap>bytes >>bitmap ]
|
||||||
[ [ width>> ] [ height>> abs ] bi 2array >>dim ]
|
[ [ width>> ] [ height>> abs ] bi 2array >>dim ]
|
||||||
[ height>> 0 < [ t >>upside-down? ] when ]
|
[ height>> 0 < [ t >>upside-down? ] when ]
|
||||||
[ bitmap>component-order >>component-order ]
|
[ bitmap>component-order >>component-order ]
|
||||||
} cleave ;
|
} cleave ;
|
||||||
|
|
||||||
M: bitmap-image load-image* ( path loading-bitmap -- bitmap )
|
M: bitmap-image load-image* ( path loading-bitmap -- bitmap )
|
||||||
swap load-bitmap-data loading-bitmap>bitmap-image ;
|
swap load-bitmap loading-bitmap>bitmap-image ;
|
||||||
|
|
||||||
|
"bmp" bitmap-image register-image-class
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
|
@ -183,7 +202,7 @@ PRIVATE>
|
||||||
! color-important
|
! color-important
|
||||||
[ drop 0 write4 ]
|
[ drop 0 write4 ]
|
||||||
|
|
||||||
! rgb-quads
|
! color-palette
|
||||||
[
|
[
|
||||||
[ bitmap>color-index ]
|
[ bitmap>color-index ]
|
||||||
[ dim>> first 3 * ]
|
[ dim>> first 3 * ]
|
||||||
|
|
|
@ -0,0 +1,29 @@
|
||||||
|
! Copyright (C) 2009 Daniel Ehrenberg.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: images tools.test kernel accessors ;
|
||||||
|
IN: images.tests
|
||||||
|
|
||||||
|
[ B{ 57 57 57 255 } ] [ 1 1 T{ image f { 2 3 } RGBA f B{
|
||||||
|
0 0 0 0
|
||||||
|
0 0 0 0
|
||||||
|
0 0 0 0
|
||||||
|
57 57 57 255
|
||||||
|
0 0 0 0
|
||||||
|
0 0 0 0
|
||||||
|
} } pixel-at ] unit-test
|
||||||
|
|
||||||
|
[ B{
|
||||||
|
0 0 0 0
|
||||||
|
0 0 0 0
|
||||||
|
0 0 0 0
|
||||||
|
57 57 57 255
|
||||||
|
0 0 0 0
|
||||||
|
0 0 0 0
|
||||||
|
} ] [ B{ 57 57 57 255 } 1 1 T{ image f { 2 3 } RGBA f B{
|
||||||
|
0 0 0 0
|
||||||
|
0 0 0 0
|
||||||
|
0 0 0 0
|
||||||
|
0 0 0 0
|
||||||
|
0 0 0 0
|
||||||
|
0 0 0 0
|
||||||
|
} } [ set-pixel-at ] keep bitmap>> ] unit-test
|
|
@ -1,6 +1,6 @@
|
||||||
! Copyright (C) 2009 Doug Coleman.
|
! Copyright (C) 2009 Doug Coleman, Daniel Ehrenberg.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: combinators kernel accessors ;
|
USING: combinators kernel accessors sequences math arrays ;
|
||||||
IN: images
|
IN: images
|
||||||
|
|
||||||
SINGLETONS: L LA BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
|
SINGLETONS: L LA BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
|
||||||
|
@ -35,3 +35,28 @@ TUPLE: image dim component-order upside-down? bitmap ;
|
||||||
: has-alpha? ( image -- ? ) component-order>> alpha-channel? ;
|
: has-alpha? ( image -- ? ) component-order>> alpha-channel? ;
|
||||||
|
|
||||||
GENERIC: load-image* ( path tuple -- image )
|
GENERIC: load-image* ( path tuple -- image )
|
||||||
|
|
||||||
|
: make-image ( bitmap -- image )
|
||||||
|
! bitmap is a sequence of sequences of pixels which are RGBA
|
||||||
|
<image>
|
||||||
|
over [ first length ] [ length ] bi 2array >>dim
|
||||||
|
RGBA >>component-order
|
||||||
|
swap concat concat B{ } like >>bitmap ;
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
: pixel@ ( x y image -- start end bitmap )
|
||||||
|
[ dim>> first * + ]
|
||||||
|
[ component-order>> bytes-per-pixel [ * dup ] keep + ]
|
||||||
|
[ bitmap>> ] tri ;
|
||||||
|
|
||||||
|
: set-subseq ( new-value from to victim -- )
|
||||||
|
<slice> 0 swap copy ; inline
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
|
: pixel-at ( x y image -- pixel )
|
||||||
|
pixel@ subseq ;
|
||||||
|
|
||||||
|
: set-pixel-at ( pixel x y image -- )
|
||||||
|
pixel@ set-subseq ;
|
||||||
|
|
|
@ -6,7 +6,7 @@ images.processing io io.binary io.encodings.binary io.files
|
||||||
io.streams.byte-array kernel locals math math.bitwise
|
io.streams.byte-array kernel locals math math.bitwise
|
||||||
math.constants math.functions math.matrices math.order
|
math.constants math.functions math.matrices math.order
|
||||||
math.ranges math.vectors memoize multiline namespaces
|
math.ranges math.vectors memoize multiline namespaces
|
||||||
sequences sequences.deep ;
|
sequences sequences.deep images.loader ;
|
||||||
IN: images.jpeg
|
IN: images.jpeg
|
||||||
|
|
||||||
QUALIFIED-WITH: bitstreams bs
|
QUALIFIED-WITH: bitstreams bs
|
||||||
|
@ -302,3 +302,5 @@ PRIVATE>
|
||||||
|
|
||||||
M: jpeg-image load-image* ( path jpeg-image -- bitmap )
|
M: jpeg-image load-image* ( path jpeg-image -- bitmap )
|
||||||
drop load-jpeg ;
|
drop load-jpeg ;
|
||||||
|
|
||||||
|
{ "jpg" "jpeg" } [ jpeg-image register-image-class ] each
|
||||||
|
|
|
@ -1,22 +1,22 @@
|
||||||
! Copyright (C) 2009 Doug Coleman.
|
! Copyright (C) 2009 Doug Coleman, Daniel Ehrenberg.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: constructors kernel splitting unicode.case combinators
|
USING: constructors kernel splitting unicode.case combinators
|
||||||
accessors images.bitmap images.tiff images io.pathnames
|
accessors images io.pathnames namespaces assocs ;
|
||||||
images.png ;
|
|
||||||
IN: images.loader
|
IN: images.loader
|
||||||
|
|
||||||
ERROR: unknown-image-extension extension ;
|
ERROR: unknown-image-extension extension ;
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
SYMBOL: types
|
||||||
|
types [ H{ } clone ] initialize
|
||||||
|
|
||||||
: image-class ( path -- class )
|
: image-class ( path -- class )
|
||||||
file-extension >lower {
|
file-extension >lower types get ?at
|
||||||
{ "bmp" [ bitmap-image ] }
|
[ unknown-image-extension ] unless ;
|
||||||
{ "tif" [ tiff-image ] }
|
PRIVATE>
|
||||||
{ "tiff" [ tiff-image ] }
|
|
||||||
! { "jpg" [ jpeg-image ] }
|
: register-image-class ( extension class -- )
|
||||||
! { "jpeg" [ jpeg-image ] }
|
swap types get set-at ;
|
||||||
{ "png" [ png-image ] }
|
|
||||||
[ unknown-image-extension ]
|
|
||||||
} case ;
|
|
||||||
|
|
||||||
: load-image ( path -- image )
|
: load-image ( path -- image )
|
||||||
dup image-class new load-image* ;
|
dup image-class new load-image* ;
|
||||||
|
|
|
@ -3,7 +3,8 @@
|
||||||
USING: accessors constructors images io io.binary io.encodings.ascii
|
USING: accessors constructors images io io.binary io.encodings.ascii
|
||||||
io.encodings.binary io.encodings.string io.files io.files.info kernel
|
io.encodings.binary io.encodings.string io.files io.files.info kernel
|
||||||
sequences io.streams.limited fry combinators arrays math
|
sequences io.streams.limited fry combinators arrays math
|
||||||
checksums checksums.crc32 compression.inflate grouping byte-arrays ;
|
checksums checksums.crc32 compression.inflate grouping byte-arrays
|
||||||
|
images.loader ;
|
||||||
IN: images.png
|
IN: images.png
|
||||||
|
|
||||||
TUPLE: png-image < image chunks
|
TUPLE: png-image < image chunks
|
||||||
|
@ -115,3 +116,5 @@ ERROR: unimplemented-color-type image ;
|
||||||
|
|
||||||
M: png-image load-image*
|
M: png-image load-image*
|
||||||
drop load-png ;
|
drop load-png ;
|
||||||
|
|
||||||
|
"png" png-image register-image-class
|
||||||
|
|
|
@ -5,7 +5,8 @@ compression.lzw constructors endian fry grouping images io
|
||||||
io.binary io.encodings.ascii io.encodings.binary
|
io.binary io.encodings.ascii io.encodings.binary
|
||||||
io.encodings.string io.encodings.utf8 io.files kernel math
|
io.encodings.string io.encodings.utf8 io.files kernel math
|
||||||
math.bitwise math.order math.parser pack prettyprint sequences
|
math.bitwise math.order math.parser pack prettyprint sequences
|
||||||
strings math.vectors specialized-arrays.float locals ;
|
strings math.vectors specialized-arrays.float locals
|
||||||
|
images.loader ;
|
||||||
IN: images.tiff
|
IN: images.tiff
|
||||||
|
|
||||||
TUPLE: tiff-image < image ;
|
TUPLE: tiff-image < image ;
|
||||||
|
@ -561,3 +562,5 @@ ERROR: unknown-component-order ifd ;
|
||||||
! tiff files can store several images -- we just take the first for now
|
! tiff files can store several images -- we just take the first for now
|
||||||
M: tiff-image load-image* ( path tiff-image -- image )
|
M: tiff-image load-image* ( path tiff-image -- image )
|
||||||
drop load-tiff tiff>image ;
|
drop load-tiff tiff>image ;
|
||||||
|
|
||||||
|
{ "tif" "tiff" } [ tiff-image register-image-class ] each
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
! Copyright (C) 2009 Daniel Ehrenberg
|
! Copyright (C) 2009 Daniel Ehrenberg
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: help.syntax help.markup math ;
|
USING: help.syntax help.markup math sequences ;
|
||||||
IN: math.bits
|
IN: math.bits
|
||||||
|
|
||||||
ABOUT: "math.bits"
|
ABOUT: "math.bits"
|
||||||
|
@ -24,3 +24,7 @@ HELP: make-bits
|
||||||
{ $example "USING: math.bits prettyprint arrays ;" "BIN: 1101 make-bits >array ." "{ t f t t }" }
|
{ $example "USING: math.bits prettyprint arrays ;" "BIN: 1101 make-bits >array ." "{ t f t t }" }
|
||||||
{ $example "USING: math.bits prettyprint arrays ;" "-3 make-bits >array ." "{ t f }" }
|
{ $example "USING: math.bits prettyprint arrays ;" "-3 make-bits >array ." "{ t f }" }
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
|
HELP: unbits
|
||||||
|
{ $values { "seq" sequence } { "number" integer } }
|
||||||
|
{ $description "Turns a sequence of booleans, of the same format made by the " { $link bits } " class, and calculates the number that it represents as little-endian." } ;
|
||||||
|
|
|
@ -29,3 +29,6 @@ IN: math.bits.tests
|
||||||
[ t ] [
|
[ t ] [
|
||||||
1067811677921310779 >bignum make-bits last
|
1067811677921310779 >bignum make-bits last
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
[ 6 ] [ 6 make-bits unbits ] unit-test
|
||||||
|
[ 6 ] [ 6 3 <bits> >array unbits ] unit-test
|
||||||
|
|
|
@ -14,3 +14,6 @@ M: bits length length>> ;
|
||||||
M: bits nth-unsafe number>> swap bit? ;
|
M: bits nth-unsafe number>> swap bit? ;
|
||||||
|
|
||||||
INSTANCE: bits immutable-sequence
|
INSTANCE: bits immutable-sequence
|
||||||
|
|
||||||
|
: unbits ( seq -- number )
|
||||||
|
<reversed> 0 [ [ 1 shift ] dip [ 1+ ] when ] reduce ;
|
||||||
|
|
|
@ -2,7 +2,7 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: namespaces cache images images.loader accessors assocs
|
USING: namespaces cache images images.loader accessors assocs
|
||||||
kernel opengl opengl.gl opengl.textures ui.gadgets.worlds
|
kernel opengl opengl.gl opengl.textures ui.gadgets.worlds
|
||||||
memoize ;
|
memoize images.tiff ;
|
||||||
IN: ui.images
|
IN: ui.images
|
||||||
|
|
||||||
TUPLE: image-name path ;
|
TUPLE: image-name path ;
|
||||||
|
@ -29,4 +29,4 @@ PRIVATE>
|
||||||
rendered-image draw-scaled-texture ;
|
rendered-image draw-scaled-texture ;
|
||||||
|
|
||||||
: image-dim ( image-name -- dim )
|
: image-dim ( image-name -- dim )
|
||||||
cached-image dim>> ;
|
cached-image dim>> ;
|
||||||
|
|
Loading…
Reference in New Issue