1 ! Copyrigt (C) 2009 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays combinators constructors destructors
4 images images.loader io io.binary io.buffers
5 io.encodings.binary io.encodings.string io.encodings.utf8
6 io.files io.files.info io.ports io.streams.limited kernel make
7 math math.bitwise math.functions multiline namespaces
8 prettyprint sequences ;
12 "gif" gif-image register-image-class
22 graphic-control-extensions
23 application-extensions
35 ERROR: unsupported-gif-format magic ;
36 ERROR: unknown-extension n ;
37 ERROR: gif-unexpected-eof ;
39 TUPLE: graphics-control-extension
40 label block-size raw-data
41 packed delay-time color-index
44 TUPLE: image-descriptor
45 separator left top width height flags ;
47 TUPLE: plain-text-extension
48 introducer label block-size text-grid-left text-grid-top text-grid-width
49 text-grid-height cell-width cell-height
50 text-fg-color-index text-bg-color-index plain-text-data ;
52 TUPLE: application-extension
53 introducer label block-size identifier authentication-code
56 TUPLE: comment-extension
57 introducer label comment-data ;
60 CONSTRUCTOR: trailer ( byte -- obj ) ;
62 CONSTANT: image-descriptor HEX: 2c
64 CONSTANT: extension-identifier HEX: 21
65 CONSTANT: plain-text-extension HEX: 01
66 CONSTANT: graphic-control-extension HEX: f9
67 CONSTANT: comment-extension HEX: fe
68 CONSTANT: application-extension HEX: ff
69 CONSTANT: trailer HEX: 3b
71 : <loading-gif> ( -- loading-gif )
73 V{ } clone >>graphic-control-extensions
74 V{ } clone >>application-extensions
75 V{ } clone >>plain-text-extensions
76 V{ } clone >>comment-extensions
79 GENERIC: stream-peek1 ( stream -- byte )
81 M: input-port stream-peek1
82 dup check-disposed dup wait-to-read
83 [ drop f ] [ buffer>> buffer-peek ] if ; inline
85 : peek1 ( -- byte ) input-stream get stream-peek1 ;
87 : (read-sub-blocks) ( -- )
88 read1 [ read , (read-sub-blocks) ] unless-zero ;
90 : read-sub-blocks ( -- bytes )
91 [ (read-sub-blocks) ] { } make B{ } concat-as ;
93 : read-image-descriptor ( -- image-descriptor )
94 \ image-descriptor new
95 1 read le> >>separator
102 : read-graphic-control-extension ( -- graphic-control-extension )
103 \ graphics-control-extension new
104 1 read le> [ >>block-size ] [ read ] bi
106 1 read le> >>block-terminator ;
108 : read-plain-text-extension ( -- plain-text-extension )
109 \ plain-text-extension new
110 1 read le> >>block-size
111 2 read le> >>text-grid-left
112 2 read le> >>text-grid-top
113 2 read le> >>text-grid-width
114 2 read le> >>text-grid-height
115 1 read le> >>cell-width
116 1 read le> >>cell-height
117 1 read le> >>text-fg-color-index
118 1 read le> >>text-bg-color-index
119 read-sub-blocks >>plain-text-data ;
121 : read-comment-extension ( -- comment-extension )
122 \ comment-extension new
123 read-sub-blocks >>comment-data ;
125 : read-application-extension ( -- read-application-extension )
126 \ application-extension new
127 1 read le> >>block-size
128 8 read utf8 decode >>identifier
129 3 read >>authentication-code
130 read-sub-blocks >>application-data ;
132 : read-gif-header ( loading-gif -- loading-gif )
133 6 read utf8 decode >>magic ;
135 ERROR: unimplemented message ;
136 : read-GIF87a ( loading-gif -- loading-gif )
137 "GIF87a" unimplemented ;
139 : read-logical-screen-descriptor ( loading-gif -- loading-gif )
143 1 read le> >>background-color
144 1 read le> >>default-aspect-ratio ;
146 : color-table? ( image -- ? ) flags>> 7 bit? ; inline
147 : interlaced? ( image -- ? ) flags>> 6 bit? ; inline
148 : sort? ( image -- ? ) flags>> 5 bit? ; inline
149 : color-table-size ( image -- ? ) flags>> 3 bits 1 + 2^ 3 * ; inline
151 : color-resolution ( image -- ? ) flags>> -4 shift 3 bits ; inline
153 : read-global-color-table ( loading-gif -- loading-gif )
155 dup color-table-size read >>global-color-table
158 : maybe-read-local-color-table ( loading-gif -- loading-gif )
159 dup image-descriptor>> color-table? [
160 dup color-table-size read >>local-color-table
163 : read-image-data ( loading-gif -- loading-gif )
164 read-sub-blocks >>compressed-bytes ;
166 : read-table-based-image ( loading-gif -- loading-gif )
167 read-image-descriptor >>image-descriptor
168 maybe-read-local-color-table
171 : read-graphic-rendering-block ( loading-gif -- loading-gif )
172 read-table-based-image ;
174 : read-extension ( loading-gif -- loading-gif )
176 { plain-text-extension [
177 read-plain-text-extension over plain-text-extensions>> push
180 { graphic-control-extension [
181 read-graphic-control-extension
182 over graphic-control-extensions>> push
184 { comment-extension [
185 read-comment-extension over comment-extensions>> push
187 { application-extension [
188 read-application-extension over application-extensions>> push
190 { f [ gif-unexpected-eof ] }
191 [ unknown-extension ]
194 ERROR: unhandled-data byte ;
196 : read-data ( loading-gif -- loading-gif )
198 { extension-identifier [ read-extension ] }
199 { graphic-control-extension [
200 read-graphic-control-extension
201 over graphic-control-extensions>> push
203 { image-descriptor [ read-table-based-image ] }
204 { trailer [ f >>loading? ] }
208 : read-GIF89a ( loading-gif -- loading-gif )
209 read-logical-screen-descriptor
210 read-global-color-table
211 [ read-data dup loading?>> ] loop ;
213 : load-gif ( stream -- loading-gif )
216 read-gif-header dup magic>> {
217 { "GIF87a" [ read-GIF87a ] }
218 { "GIF89a" [ read-GIF89a ] }
219 [ unsupported-gif-format ]
221 ] with-input-stream ;
223 : loading-gif>image ( loading-gif -- image )
226 ERROR: loading-gif-error gif-image ;
228 : ensure-loaded ( gif-image -- gif-image )
229 dup loading?>> [ loading-gif-error ] when ;
231 M: gif-image stream>image ( path gif-image -- image )
232 drop load-gif ensure-loaded loading-gif>image ;