steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Slava Pestov 2009-06-03 03:23:04 -05:00
parent ade5db2405 f31c3f867a
commit 9fa3240b85
13 changed files with 132 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
basis/compression/run-length/run-length.factor Normal file
View File

@ -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 ;

3
basis/images/authors.txt
View File

@ -1 +1,2 @@
Doug Coleman
Doug Coleman
Daniel Ehrenberg

43
basis/images/bitmap/bitmap.factor
View File

@ -1,9 +1,10 @@
! Copyright (C) 2007, 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types arrays byte-arrays columns
combinators fry grouping io io.binary io.encodings.binary io.files
kernel macros math math.bitwise math.functions namespaces sequences
strings images endian summary locals ;
combinators compression.run-length endian fry grouping images
images.loader io io.binary io.encodings.binary io.files kernel
locals macros math math.bitwise math.functions namespaces
sequences strings summary ;
IN: images.bitmap
: assert-sequence= ( a b -- )
@ -21,7 +22,8 @@ TUPLE: bitmap-image < image ;
TUPLE: loading-bitmap
size reserved offset header-length width
height planes bit-count compression size-image
x-pels y-pels color-used color-important rgb-quads color-index ;
x-pels y-pels color-used color-important color-palette color-index
uncompressed-bytes ;
ERROR: bitmap-magic magic ;
@ -31,7 +33,7 @@ M: bitmap-magic summary
<PRIVATE
: 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 ;
ERROR: bmp-not-supported n ;
@ -39,7 +41,7 @@ ERROR: bmp-not-supported n ;
: reverse-lines ( byte-array width -- byte-array )
<sliced-groups> <reversed> concat ; inline
: raw-bitmap>seq ( loading-bitmap -- array )
: bitmap>bytes ( loading-bitmap -- array )
dup bit-count>>
{
{ 32 [ color-index>> ] }
@ -48,6 +50,21 @@ ERROR: bmp-not-supported n ;
[ bmp-not-supported ]
} 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 )
2 read "BM" assert-sequence=
read4 >>size
@ -67,7 +84,7 @@ ERROR: bmp-not-supported n ;
read4 >>color-used
read4 >>color-important ;
: rgb-quads-length ( loading-bitmap -- n )
: color-palette-length ( loading-bitmap -- n )
[ offset>> 14 - ] [ header-length>> ] bi - ;
: color-index-length ( loading-bitmap -- n )
@ -98,11 +115,11 @@ ERROR: bmp-not-supported n ;
] when ;
: 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
fixup-color-index ;
: load-bitmap-data ( path -- loading-bitmap )
: load-bitmap ( path -- loading-bitmap )
binary [
loading-bitmap new
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 )
{
[ raw-bitmap>seq >>bitmap ]
[ loading-bitmap>bytes >>bitmap ]
[ [ width>> ] [ height>> abs ] bi 2array >>dim ]
[ height>> 0 < [ t >>upside-down? ] when ]
[ bitmap>component-order >>component-order ]
} cleave ;
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>
@ -183,7 +202,7 @@ PRIVATE>
! color-important
[ drop 0 write4 ]
! rgb-quads
! color-palette
[
[ bitmap>color-index ]
[ dim>> first 3 * ]

29
basis/images/images-tests.factor Normal file
View File

@ -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

29
basis/images/images.factor
View File

@ -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.
USING: combinators kernel accessors ;
USING: combinators kernel accessors sequences math arrays ;
IN: images
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? ;
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 ;

4
basis/images/jpeg/jpeg.factor
View File

@ -6,7 +6,7 @@ images.processing io io.binary io.encodings.binary io.files
io.streams.byte-array kernel locals math math.bitwise
math.constants math.functions math.matrices math.order
math.ranges math.vectors memoize multiline namespaces
sequences sequences.deep ;
sequences sequences.deep images.loader ;
IN: images.jpeg
QUALIFIED-WITH: bitstreams bs
@ -302,3 +302,5 @@ PRIVATE>
M: jpeg-image load-image* ( path jpeg-image -- bitmap )
drop load-jpeg ;
{ "jpg" "jpeg" } [ jpeg-image register-image-class ] each

24
basis/images/loader/loader.factor
View File

@ -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.
USING: constructors kernel splitting unicode.case combinators
accessors images.bitmap images.tiff images io.pathnames
images.png ;
accessors images io.pathnames namespaces assocs ;
IN: images.loader
ERROR: unknown-image-extension extension ;
<PRIVATE
SYMBOL: types
types [ H{ } clone ] initialize
: image-class ( path -- class )
file-extension >lower {
{ "bmp" [ bitmap-image ] }
{ "tif" [ tiff-image ] }
{ "tiff" [ tiff-image ] }
! { "jpg" [ jpeg-image ] }
! { "jpeg" [ jpeg-image ] }
{ "png" [ png-image ] }
[ unknown-image-extension ]
} case ;
file-extension >lower types get ?at
[ unknown-image-extension ] unless ;
PRIVATE>
: register-image-class ( extension class -- )
swap types get set-at ;
: load-image ( path -- image )
dup image-class new load-image* ;

5
basis/images/png/png.factor
View File

@ -3,7 +3,8 @@
USING: accessors constructors images io io.binary io.encodings.ascii
io.encodings.binary io.encodings.string io.files io.files.info kernel
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
TUPLE: png-image < image chunks
@ -115,3 +116,5 @@ ERROR: unimplemented-color-type image ;
M: png-image load-image*
drop load-png ;
"png" png-image register-image-class

5
basis/images/tiff/tiff.factor
View File

@ -5,7 +5,8 @@ compression.lzw constructors 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 prettyprint sequences
strings math.vectors specialized-arrays.float locals ;
strings math.vectors specialized-arrays.float locals
images.loader ;
IN: images.tiff
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
M: tiff-image load-image* ( path tiff-image -- image )
drop load-tiff tiff>image ;
{ "tif" "tiff" } [ tiff-image register-image-class ] each

6
basis/math/bits/bits-docs.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2009 Daniel Ehrenberg
! 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
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 ;" "-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." } ;

3
basis/math/bits/bits-tests.factor
View File

@ -29,3 +29,6 @@ IN: math.bits.tests
[ t ] [
1067811677921310779 >bignum make-bits last
] unit-test
[ 6 ] [ 6 make-bits unbits ] unit-test
[ 6 ] [ 6 3 <bits> >array unbits ] unit-test

3
basis/math/bits/bits.factor
View File

@ -14,3 +14,6 @@ M: bits length length>> ;
M: bits nth-unsafe number>> swap bit? ;
INSTANCE: bits immutable-sequence
: unbits ( seq -- number )
<reversed> 0 [ [ 1 shift ] dip [ 1+ ] when ] reduce ;

4
basis/ui/images/images.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces cache images images.loader accessors assocs
kernel opengl opengl.gl opengl.textures ui.gadgets.worlds
memoize ;
memoize images.tiff ;
IN: ui.images
TUPLE: image-name path ;
@ -29,4 +29,4 @@ PRIVATE>
rendered-image draw-scaled-texture ;
: image-dim ( image-name -- dim )
cached-image dim>> ;
cached-image dim>> ;