-! Copyrigt (C) 2009 Doug Coleman.
+! Copyrigt (C) 2009 Doug Coleman, Keith Lazuka
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays combinators constructors destructors
-images images.loader io io.binary io.buffers
-io.encodings.binary io.encodings.string io.encodings.utf8
-io.files io.files.info io.ports io.streams.limited kernel make
-math math.bitwise math.functions multiline namespaces
-prettyprint sequences ;
+USING: accessors arrays combinators compression.lzw constructors
+endian grouping images images.loader io io.encodings.string
+io.encodings.utf8 kernel make math math.bitwise sequences ;
IN: images.gif
SINGLETON: gif-image
-"gif" gif-image register-image-class
+"gif" gif-image ?register-image-class
TUPLE: loading-gif
loading?
ERROR: gif-unexpected-eof ;
TUPLE: graphics-control-extension
-label block-size raw-data
-packed delay-time color-index
-block-terminator ;
+flags delay-time transparent-color-index ;
TUPLE: image-descriptor
-separator left top width height flags ;
+left top width height flags first-code-size ;
TUPLE: plain-text-extension
introducer label block-size text-grid-left text-grid-top text-grid-width
introducer label comment-data ;
TUPLE: trailer byte ;
-CONSTRUCTOR: trailer ( byte -- obj ) ;
+CONSTRUCTOR: <trailer> trailer ( byte -- obj ) ;
-CONSTANT: image-descriptor HEX: 2c
+CONSTANT: IMAGE-DESCRIPTOR 0x2c
! Extensions
-CONSTANT: extension-identifier HEX: 21
-CONSTANT: plain-text-extension HEX: 01
-CONSTANT: graphic-control-extension HEX: f9
-CONSTANT: comment-extension HEX: fe
-CONSTANT: application-extension HEX: ff
-CONSTANT: trailer HEX: 3b
+CONSTANT: EXTENSION-IDENTIFIER 0x21
+CONSTANT: PLAIN-TEXT-EXTENSION 0x01
+CONSTANT: GRAPHICS-CONTROL-EXTENSION 0xf9
+CONSTANT: COMMENT-EXTENSION 0xfe
+CONSTANT: APPLICATION-EXTENSION 0xff
+CONSTANT: TRAILER 0x3b
+CONSTANT: GRAPHIC-CONTROL-EXTENSION-BLOCK-SIZE 0x04
+CONSTANT: BLOCK-TERMINATOR 0x00
: <loading-gif> ( -- loading-gif )
\ loading-gif new
V{ } clone >>comment-extensions
t >>loading? ;
-GENERIC: stream-peek1 ( stream -- byte )
-
-M: input-port stream-peek1
- dup check-disposed dup wait-to-read
- [ drop f ] [ buffer>> buffer-peek ] if ; inline
-
-: peek1 ( -- byte ) input-stream get stream-peek1 ;
-
: (read-sub-blocks) ( -- )
read1 [ read , (read-sub-blocks) ] unless-zero ;
: read-image-descriptor ( -- image-descriptor )
\ image-descriptor new
- 1 read le> >>separator
2 read le> >>left
2 read le> >>top
2 read le> >>width
2 read le> >>height
- 1 read le> >>flags ;
+ 1 read le> >>flags
+ 1 read le> 1 + >>first-code-size ;
: read-graphic-control-extension ( -- graphic-control-extension )
\ graphics-control-extension new
- 1 read le> [ >>block-size ] [ read ] bi
- >>raw-data
- 1 read le> >>block-terminator ;
+ 1 read le> GRAPHIC-CONTROL-EXTENSION-BLOCK-SIZE assert=
+ 1 read le> >>flags
+ 2 read le> >>delay-time
+ 1 read le> >>transparent-color-index
+ 1 read le> BLOCK-TERMINATOR assert= ;
: read-plain-text-extension ( -- plain-text-extension )
\ plain-text-extension new
: read-comment-extension ( -- comment-extension )
\ comment-extension new
read-sub-blocks >>comment-data ;
-
+
: read-application-extension ( -- read-application-extension )
\ application-extension new
1 read le> >>block-size
: interlaced? ( image -- ? ) flags>> 6 bit? ; inline
: sort? ( image -- ? ) flags>> 5 bit? ; inline
: color-table-size ( image -- ? ) flags>> 3 bits 1 + 2^ 3 * ; inline
+: transparency? ( image -- ? )
+ graphic-control-extensions>>
+ [ f ] [ first flags>> 0 bit? ] if-empty ; inline
: color-resolution ( image -- ? ) flags>> -4 shift 3 bits ; inline
: read-global-color-table ( loading-gif -- loading-gif )
dup color-table? [
- dup color-table-size read >>global-color-table
+ dup color-table-size read 3 group >>global-color-table
] when ;
: maybe-read-local-color-table ( loading-gif -- loading-gif )
: read-extension ( loading-gif -- loading-gif )
read1 {
- { plain-text-extension [
+ { PLAIN-TEXT-EXTENSION [
read-plain-text-extension over plain-text-extensions>> push
] }
- { graphic-control-extension [
+ { GRAPHICS-CONTROL-EXTENSION [
read-graphic-control-extension
over graphic-control-extensions>> push
] }
- { comment-extension [
+ { COMMENT-EXTENSION [
read-comment-extension over comment-extensions>> push
] }
- { application-extension [
+ { APPLICATION-EXTENSION [
read-application-extension over application-extensions>> push
] }
{ f [ gif-unexpected-eof ] }
: read-data ( loading-gif -- loading-gif )
read1 {
- { extension-identifier [ read-extension ] }
- { graphic-control-extension [
+ { EXTENSION-IDENTIFIER [ read-extension ] }
+ { GRAPHICS-CONTROL-EXTENSION [
read-graphic-control-extension
over graphic-control-extensions>> push
] }
- { image-descriptor [ read-table-based-image ] }
- { trailer [ f >>loading? ] }
+ { IMAGE-DESCRIPTOR [ read-table-based-image ] }
+ { TRAILER [ f >>loading? ] }
[ unhandled-data ]
} case ;
} case
] with-input-stream ;
-: loading-gif>image ( loading-gif -- image )
- ;
+: decompress ( loading-gif -- indexes )
+ [ compressed-bytes>> ]
+ [ image-descriptor>> first-code-size>> ] bi
+ gif-lzw-uncompress ;
+
+: colorize ( index palette transparent-index/f -- seq )
+ pick = [ 2drop B{ 0 0 0 0 } ] [ nth 255 suffix ] if ;
+
+: apply-palette ( indexes palette transparent-index/f -- bitmap )
+ [ colorize ] 2curry V{ } map-as concat ;
+
+: dimensions ( loading-gif -- dim )
+ [ image-descriptor>> width>> ] [ image-descriptor>> height>> ] bi 2array ;
+
+: ?transparent-color-index ( loading-gif -- index/f )
+ dup transparency?
+ [ graphic-control-extensions>> first transparent-color-index>> ]
+ [ drop f ] if ;
+
+: gif>image ( loading-gif -- image )
+ [ <image> ] dip
+ [ dimensions >>dim ]
+ [ drop RGBA >>component-order ubyte-components >>component-type ]
+ [
+ [ decompress ] [ global-color-table>> ] [ ?transparent-color-index ] tri
+ apply-palette >>bitmap
+ ] tri ;
ERROR: loading-gif-error gif-image ;
: ensure-loaded ( gif-image -- gif-image )
dup loading?>> [ loading-gif-error ] when ;
-M: gif-image stream>image ( path gif-image -- image )
- drop load-gif ensure-loaded loading-gif>image ;
+M: gif-image stream>image* ( path gif-image -- image )
+ drop load-gif ensure-loaded gif>image ;
projects / factor.git / blobdiff