1 ! Copyrigt (C) 2009 Doug Coleman, Keith Lazuka
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays combinators compression.lzw
4 constructors destructors endian grouping images images.loader
5 io io.buffers io.encodings.string io.encodings.utf8
6 kernel make math math.bitwise namespaces sequences ;
10 "gif" gif-image ?register-image-class
20 graphic-control-extensions
21 application-extensions
33 ERROR: unsupported-gif-format magic ;
34 ERROR: unknown-extension n ;
35 ERROR: gif-unexpected-eof ;
37 TUPLE: graphics-control-extension
38 flags delay-time transparent-color-index ;
40 TUPLE: image-descriptor
41 left top width height flags first-code-size ;
43 TUPLE: plain-text-extension
44 introducer label block-size text-grid-left text-grid-top text-grid-width
45 text-grid-height cell-width cell-height
46 text-fg-color-index text-bg-color-index plain-text-data ;
48 TUPLE: application-extension
49 introducer label block-size identifier authentication-code
52 TUPLE: comment-extension
53 introducer label comment-data ;
56 CONSTRUCTOR: <trailer> trailer ( byte -- obj ) ;
58 CONSTANT: IMAGE-DESCRIPTOR 0x2c
60 CONSTANT: EXTENSION-IDENTIFIER 0x21
61 CONSTANT: PLAIN-TEXT-EXTENSION 0x01
62 CONSTANT: GRAPHICS-CONTROL-EXTENSION 0xf9
63 CONSTANT: COMMENT-EXTENSION 0xfe
64 CONSTANT: APPLICATION-EXTENSION 0xff
65 CONSTANT: TRAILER 0x3b
66 CONSTANT: GRAPHIC-CONTROL-EXTENSION-BLOCK-SIZE 0x04
67 CONSTANT: BLOCK-TERMINATOR 0x00
69 : <loading-gif> ( -- loading-gif )
71 V{ } clone >>graphic-control-extensions
72 V{ } clone >>application-extensions
73 V{ } clone >>plain-text-extensions
74 V{ } clone >>comment-extensions
77 : (read-sub-blocks) ( -- )
78 read1 [ read , (read-sub-blocks) ] unless-zero ;
80 : read-sub-blocks ( -- bytes )
81 [ (read-sub-blocks) ] { } make B{ } concat-as ;
83 : read-image-descriptor ( -- image-descriptor )
84 \ image-descriptor new
90 1 read le> 1 + >>first-code-size ;
92 : read-graphic-control-extension ( -- graphic-control-extension )
93 \ graphics-control-extension new
94 1 read le> GRAPHIC-CONTROL-EXTENSION-BLOCK-SIZE assert=
96 2 read le> >>delay-time
97 1 read le> >>transparent-color-index
98 1 read le> BLOCK-TERMINATOR assert= ;
100 : read-plain-text-extension ( -- plain-text-extension )
101 \ plain-text-extension new
102 1 read le> >>block-size
103 2 read le> >>text-grid-left
104 2 read le> >>text-grid-top
105 2 read le> >>text-grid-width
106 2 read le> >>text-grid-height
107 1 read le> >>cell-width
108 1 read le> >>cell-height
109 1 read le> >>text-fg-color-index
110 1 read le> >>text-bg-color-index
111 read-sub-blocks >>plain-text-data ;
113 : read-comment-extension ( -- comment-extension )
114 \ comment-extension new
115 read-sub-blocks >>comment-data ;
117 : read-application-extension ( -- read-application-extension )
118 \ application-extension new
119 1 read le> >>block-size
120 8 read utf8 decode >>identifier
121 3 read >>authentication-code
122 read-sub-blocks >>application-data ;
124 : read-gif-header ( loading-gif -- loading-gif )
125 6 read utf8 decode >>magic ;
127 ERROR: unimplemented message ;
128 : read-GIF87a ( loading-gif -- loading-gif )
129 "GIF87a" unimplemented ;
131 : read-logical-screen-descriptor ( loading-gif -- loading-gif )
135 1 read le> >>background-color
136 1 read le> >>default-aspect-ratio ;
138 : color-table? ( image -- ? ) flags>> 7 bit? ; inline
139 : interlaced? ( image -- ? ) flags>> 6 bit? ; inline
140 : sort? ( image -- ? ) flags>> 5 bit? ; inline
141 : color-table-size ( image -- ? ) flags>> 3 bits 1 + 2^ 3 * ; inline
142 : transparency? ( image -- ? )
143 graphic-control-extensions>>
144 [ f ] [ first flags>> 0 bit? ] if-empty ; inline
146 : color-resolution ( image -- ? ) flags>> -4 shift 3 bits ; inline
148 : read-global-color-table ( loading-gif -- loading-gif )
150 dup color-table-size read 3 group >>global-color-table
153 : maybe-read-local-color-table ( loading-gif -- loading-gif )
154 dup image-descriptor>> color-table? [
155 dup color-table-size read >>local-color-table
158 : read-image-data ( loading-gif -- loading-gif )
159 read-sub-blocks >>compressed-bytes ;
161 : read-table-based-image ( loading-gif -- loading-gif )
162 read-image-descriptor >>image-descriptor
163 maybe-read-local-color-table
166 : read-graphic-rendering-block ( loading-gif -- loading-gif )
167 read-table-based-image ;
169 : read-extension ( loading-gif -- loading-gif )
171 { PLAIN-TEXT-EXTENSION [
172 read-plain-text-extension over plain-text-extensions>> push
175 { GRAPHICS-CONTROL-EXTENSION [
176 read-graphic-control-extension
177 over graphic-control-extensions>> push
179 { COMMENT-EXTENSION [
180 read-comment-extension over comment-extensions>> push
182 { APPLICATION-EXTENSION [
183 read-application-extension over application-extensions>> push
185 { f [ gif-unexpected-eof ] }
186 [ unknown-extension ]
189 ERROR: unhandled-data byte ;
191 : read-data ( loading-gif -- loading-gif )
193 { EXTENSION-IDENTIFIER [ read-extension ] }
194 { GRAPHICS-CONTROL-EXTENSION [
195 read-graphic-control-extension
196 over graphic-control-extensions>> push
198 { IMAGE-DESCRIPTOR [ read-table-based-image ] }
199 { TRAILER [ f >>loading? ] }
203 : read-GIF89a ( loading-gif -- loading-gif )
204 read-logical-screen-descriptor
205 read-global-color-table
206 [ read-data dup loading?>> ] loop ;
208 : load-gif ( stream -- loading-gif )
211 read-gif-header dup magic>> {
212 { "GIF87a" [ read-GIF87a ] }
213 { "GIF89a" [ read-GIF89a ] }
214 [ unsupported-gif-format ]
216 ] with-input-stream ;
218 : decompress ( loading-gif -- indexes )
219 [ compressed-bytes>> ]
220 [ image-descriptor>> first-code-size>> ] bi
223 : colorize ( index palette transparent-index/f -- seq )
224 pick = [ 2drop B{ 0 0 0 0 } ] [ nth 255 suffix ] if ;
226 : apply-palette ( indexes palette transparent-index/f -- bitmap )
227 [ colorize ] 2curry V{ } map-as concat ;
229 : dimensions ( loading-gif -- dim )
230 [ image-descriptor>> width>> ] [ image-descriptor>> height>> ] bi 2array ;
232 : ?transparent-color-index ( loading-gif -- index/f )
234 [ graphic-control-extensions>> first transparent-color-index>> ]
237 : gif>image ( loading-gif -- image )
240 [ drop RGBA >>component-order ubyte-components >>component-type ]
242 [ decompress ] [ global-color-table>> ] [ ?transparent-color-index ] tri
243 apply-palette >>bitmap
246 ERROR: loading-gif-error gif-image ;
248 : ensure-loaded ( gif-image -- gif-image )
249 dup loading?>> [ loading-gif-error ] when ;
251 M: gif-image stream>image* ( path gif-image -- image )
252 drop load-gif ensure-loaded gif>image ;