1 ! Copyright (C) 2010 Erik Charlebois
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays calendar colors combinators
4 continuations endian hashtables images images.loader io
5 io.encodings.ascii io.encodings.string io.streams.throwing
6 kernel math math.parser ranges sequences ;
10 "tga" tga-image ?register-image-class
12 ERROR: bad-tga-header ;
13 ERROR: bad-tga-footer ;
14 ERROR: bad-tga-extension-size ;
15 ERROR: bad-tga-timestamp ;
16 ERROR: bad-tga-unsupported ;
18 : read-id-length ( -- byte )
21 : read-color-map-type ( -- byte )
23 { 0 1 } member? [ bad-tga-header ] unless ;
25 : read-image-type ( -- byte )
27 { 0 1 2 3 9 10 11 } member? [ bad-tga-header ] unless ; inline
29 : read-color-map-first ( -- short )
32 : read-color-map-length ( -- short )
35 : read-color-map-entry-size ( -- byte )
38 : read-x-origin ( -- short )
41 : read-y-origin ( -- short )
44 : read-image-width ( -- short )
47 : read-image-height ( -- short )
50 : read-pixel-depth ( -- byte )
53 : read-image-descriptor ( -- alpha-bits pixel-order )
55 [ 7 bitand ] [ 24 bitand -3 shift ] bi ; inline
57 : read-image-id ( length -- image-id )
60 : read-color-map ( type length elt-size -- color-map )
61 pick 1 = [ 8 align 8 / * read ] [ 2drop f ] if nip ; inline
63 : read-image-data ( width height depth -- image-data )
64 8 align 8 / * * read ; inline
66 : read-extension-area-offset ( -- offset )
69 : read-developer-directory-offset ( -- offset )
72 : read-signature ( -- )
73 18 read ascii decode "TRUEVISION-XFILE.\0" = [ bad-tga-footer ] unless ; inline
75 : read-extension-size ( -- )
76 2 read le> 495 = [ bad-tga-extension-size ] unless ; inline
78 : read-author-name ( -- string )
79 41 read ascii decode [ 0 = ] trim ; inline
81 : read-author-comments ( -- string )
82 4 <iota> [ drop 81 read ascii decode [ 0 = ] trim ] map concat ; inline
84 : read-date-timestamp ( -- timestamp )
86 2 read le> dup 12 [1..b] member? [ bad-tga-timestamp ] unless >>month
87 2 read le> dup 31 [1..b] member? [ bad-tga-timestamp ] unless >>day
89 2 read le> dup 23 [0..b] member? [ bad-tga-timestamp ] unless >>hour
90 2 read le> dup 59 [0..b] member? [ bad-tga-timestamp ] unless >>minute
91 2 read le> dup 59 [0..b] member? [ bad-tga-timestamp ] unless >>second ; inline
93 : read-job-name ( -- string )
94 41 read ascii decode [ 0 = ] trim ; inline
96 : read-job-time ( -- duration )
99 2 read le> dup 59 [0..b] member? [ bad-tga-timestamp ] unless >>minute
100 2 read le> dup 59 [0..b] member? [ bad-tga-timestamp ] unless >>second ; inline
102 : read-software-id ( -- string )
103 41 read ascii decode [ 0 = ] trim ; inline
105 : read-software-version ( -- string )
106 2 read le> 100 /f number>string
107 1 read ascii decode append [ " " = ] trim ; inline
109 :: read-key-color ( -- color )
110 1 read le> 255 /f :> alpha
114 alpha <rgba> ; inline
116 : read-pixel-aspect-ratio ( -- aspect-ratio )
117 2 read le> 2 read le> /f ; inline
119 : read-gamma-value ( -- gamma-value )
120 2 read le> 2 read le> /f ; inline
122 : read-color-correction-offset ( -- offset )
125 : read-postage-stamp-offset ( -- offset )
128 : read-scan-line-offset ( -- offset )
131 : read-premultiplied-alpha ( -- boolean )
132 1 read le> 4 = ; inline
134 : read-scan-line-table ( height -- scan-offsets )
135 <iota> [ drop 4 read le> ] map ; inline
137 : read-postage-stamp-image ( depth -- postage-data )
138 8 align 8 / 1 read le> 1 read le> * * read ; inline
140 :: read-color-correction-table ( -- correction-table )
147 2 read le> 65535 /f :> alpha
155 : read-developer-directory ( -- developer-directory )
165 : read-developer-areas ( developer-directory -- developer-area-map )
168 [ dup third second seek-absolute seek-input read ] bi 2array
169 ] map >hashtable ; inline
171 :: read-tga ( -- image )
173 read-id-length :> id-length
174 read-color-map-type :> map-type
175 read-image-type :> image-type
176 read-color-map-first :> map-first
177 read-color-map-length :> map-length
178 read-color-map-entry-size :> map-entry-size
179 read-x-origin :> x-origin
180 read-y-origin :> y-origin
181 read-image-width :> image-width
182 read-image-height :> image-height
183 read-pixel-depth :> pixel-depth
184 read-image-descriptor :> ( alpha-bits pixel-order )
185 id-length read-image-id :> image-id
186 map-type map-length map-entry-size read-color-map :> color-map-data
187 image-width image-height pixel-depth read-image-data :> image-data
190 ! Read optional footer
191 26 seek-end seek-input
192 read-extension-area-offset :> extension-offset
193 read-developer-directory-offset :> directory-offset
196 ! Read optional extension section
199 extension-offset seek-absolute seek-input
201 read-author-name :> author-name
202 read-author-comments :> author-comments
203 read-date-timestamp :> date-timestamp
204 read-job-name :> job-name
205 read-job-time :> job-time
206 read-software-id :> software-id
207 read-software-version :> software-version
208 read-key-color :> key-color
209 read-pixel-aspect-ratio :> aspect-ratio
210 read-gamma-value :> gamma-value
211 read-color-correction-offset :> color-correction-offset
212 read-postage-stamp-offset :> postage-stamp-offset
213 read-scan-line-offset :> scan-line-offset
214 read-premultiplied-alpha :> premultiplied-alpha
216 color-correction-offset 0 =
218 color-correction-offset seek-absolute seek-input
219 read-color-correction-table :> color-correction-table
222 postage-stamp-offset 0 =
224 postage-stamp-offset seek-absolute seek-input
225 pixel-depth read-postage-stamp-image :> postage-data
228 scan-line-offset seek-absolute seek-input
229 image-height read-scan-line-table :> scan-offsets
231 ! Read optional developer section
235 directory-offset seek-absolute seek-input
236 read-developer-directory read-developer-areas
237 ] if :> developer-areas
241 ! Only 24-bit uncompressed BGR and 32-bit uncompressed BGRA are supported.
242 ! Other formats would need to be converted to work within the image class.
243 map-type 0 = [ bad-tga-unsupported ] unless
244 image-type 2 = [ bad-tga-unsupported ] unless
245 pixel-depth { 24 32 } member? [ bad-tga-unsupported ] unless
246 pixel-order { 0 2 } member? [ bad-tga-unsupported ] unless
248 ! Create image instance
250 alpha-bits 0 = [ BGR ] [ BGRA ] if >>component-order
251 { image-width image-height } >>dim
252 pixel-order 0 = >>upside-down?
254 ubyte-components >>component-type ;
256 M: tga-image stream>image*
257 drop [ [ read-tga ] throw-on-eof ] with-input-stream ;
259 M: tga-image image>stream
262 component-order>> { BGRA BGRA } member? [ bad-tga-unsupported ] unless
265 B{ 0 } write ! id-length
266 B{ 0 } write ! map-type
267 B{ 2 } write ! image-type
268 B{ 0 0 0 0 0 } write ! color map first, length, entry size
269 B{ 0 0 0 0 } write ! x-origin, y-origin
271 [ dim>> first 2 >le write ]
272 [ dim>> second 2 >le write ]
275 { BGR [ B{ 24 } write ] }
276 { BGRA [ B{ 32 } write ] }
280 dup component-order>>
285 upside-down?>> [ 0 ] [ 2 ] if 3 shift bitor