extra/images/tga/tga.factor

   1 ! Copyright (C) 2010 Erik Charlebois
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors images images.loader io io.binary kernel
   4 locals math sequences io.encodings.ascii io.encodings.string
   5 calendar math.ranges math.parser colors arrays hashtables
   6 ui.pixel-formats combinators continuations io.streams.throwing ;
   7 IN: images.tga
   8
   9 SINGLETON: tga-image
  10 "tga" tga-image ?register-image-class
  11
  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 ;
  17
  18 : read-id-length ( -- byte )
  19     1 read le> ; inline
  20
  21 : read-color-map-type ( -- byte )
  22     1 read le> dup
  23     { 0 1 } member? [ bad-tga-header ] unless ;
  24
  25 : read-image-type ( -- byte )
  26     1 read le> dup
  27     { 0 1 2 3 9 10 11 } member? [ bad-tga-header ] unless ; inline
  28
  29 : read-color-map-first ( -- short )
  30     2 read le> ; inline
  31
  32 : read-color-map-length ( -- short )
  33     2 read le> ; inline
  34
  35 : read-color-map-entry-size ( -- byte )
  36     1 read le> ; inline
  37
  38 : read-x-origin ( -- short )
  39     2 read le> ; inline
  40
  41 : read-y-origin ( -- short )
  42     2 read le> ; inline
  43
  44 : read-image-width ( -- short )
  45     2 read le> ; inline
  46
  47 : read-image-height ( -- short )
  48     2 read le> ; inline
  49
  50 : read-pixel-depth ( -- byte )
  51     1 read le> ; inline
  52
  53 : read-image-descriptor ( -- alpha-bits pixel-order )
  54     1 read le>
  55     [ 7 bitand ] [ 24 bitand -3 shift ] bi ; inline
  56
  57 : read-image-id ( length -- image-id )
  58     read ; inline
  59
  60 : read-color-map ( type length elt-size -- color-map )
  61     pick 1 = [ 8 align 8 / * read ] [ 2drop f ] if nip ; inline
  62
  63 : read-image-data ( width height depth -- image-data )
  64     8 align 8 / * * read ; inline
  65
  66 : read-extension-area-offset ( -- offset )
  67     4 read le> ; inline
  68
  69 : read-developer-directory-offset ( -- offset )
  70     4 read le> ; inline
  71
  72 : read-signature ( -- )
  73     18 read ascii decode "TRUEVISION-XFILE.\0" = [ bad-tga-footer ] unless ; inline
  74
  75 : read-extension-size ( -- )
  76     2 read le> 495 = [ bad-tga-extension-size ] unless ; inline
  77
  78 : read-author-name ( -- string )
  79     41 read ascii decode [ 0 = ] trim ; inline
  80
  81 : read-author-comments ( -- string )
  82     4 <iota> [ drop 81 read ascii decode [ 0 = ] trim ] map concat ; inline
  83
  84 : read-date-timestamp ( -- timestamp )
  85     timestamp new
  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
  88     2 read le>                                                   >>year
  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
  92
  93 : read-job-name ( -- string )
  94     41 read ascii decode [ 0 = ] trim ; inline
  95
  96 : read-job-time ( -- duration )
  97     duration new
  98     2 read le>                                                   >>hour
  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
 101
 102 : read-software-id ( -- string )
 103     41 read ascii decode [ 0 = ] trim ; inline
 104
 105 : read-software-version ( -- string )
 106     2 read le> 100 /f number>string
 107     1 read ascii decode append [ " " = ] trim ; inline
 108
 109 :: read-key-color ( -- color )
 110     1 read le> 255 /f :> alpha
 111     1 read le> 255 /f
 112     1 read le> 255 /f
 113     1 read le> 255 /f
 114     alpha <rgba> ; inline
 115
 116 : read-pixel-aspect-ratio ( -- aspect-ratio )
 117     2 read le> 2 read le> /f ; inline
 118
 119 : read-gamma-value ( -- gamma-value )
 120     2 read le> 2 read le> /f ; inline
 121
 122 : read-color-correction-offset ( -- offset )
 123     4 read le> ; inline
 124
 125 : read-postage-stamp-offset ( -- offset )
 126     4 read le> ; inline
 127
 128 : read-scan-line-offset ( -- offset )
 129     4 read le> ; inline
 130
 131 : read-premultiplied-alpha ( -- boolean )
 132     1 read le> 4 = ; inline
 133
 134 : read-scan-line-table ( height -- scan-offsets )
 135     <iota> [ drop 4 read le> ] map ; inline
 136
 137 : read-postage-stamp-image ( depth -- postage-data )
 138     8 align 8 / 1 read le> 1 read le> * * read ; inline
 139
 140 :: read-color-correction-table ( -- correction-table )
 141     256 <iota>
 142     [
 143         drop
 144         4 <iota>
 145         [
 146             drop
 147             2 read le> 65535 /f :> alpha
 148             2 read le> 65535 /f
 149             2 read le> 65535 /f
 150             2 read le> 65535 /f
 151             alpha <rgba>
 152         ] map
 153     ] map ; inline
 154
 155 : read-developer-directory ( -- developer-directory )
 156     2 read le> <iota>
 157     [
 158         drop
 159         2 read le>
 160         4 read le>
 161         4 read le>
 162         3array
 163     ] map ; inline
 164
 165 : read-developer-areas ( developer-directory -- developer-area-map )
 166     [
 167         [ first ]
 168         [ dup third second seek-absolute seek-input read ] bi 2array
 169     ] map >hashtable ; inline
 170
 171 :: read-tga ( -- image )
 172     ! Read header
 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
 188
 189     [
 190         ! Read optional footer
 191         26 seek-end seek-input
 192         read-extension-area-offset      :> extension-offset
 193         read-developer-directory-offset :> directory-offset
 194         read-signature
 195
 196         ! Read optional extension section
 197         extension-offset 0 =
 198         [
 199             extension-offset seek-absolute seek-input
 200             read-extension-size
 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
 215
 216             color-correction-offset 0 =
 217             [
 218                 color-correction-offset seek-absolute seek-input
 219                 read-color-correction-table :> color-correction-table
 220             ] unless
 221
 222             postage-stamp-offset 0 =
 223             [
 224                 postage-stamp-offset seek-absolute seek-input
 225                 pixel-depth read-postage-stamp-image :> postage-data
 226             ] unless
 227
 228             scan-line-offset seek-absolute seek-input
 229             image-height read-scan-line-table :> scan-offsets
 230
 231             ! Read optional developer section
 232             directory-offset 0 =
 233             [ f ]
 234             [
 235                 directory-offset seek-absolute seek-input
 236                 read-developer-directory read-developer-areas
 237             ] if :> developer-areas
 238         ] unless
 239     ] ignore-errors
 240
 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
 247
 248     ! Create image instance
 249     image new
 250     alpha-bits 0 = [ BGR ] [ BGRA ] if >>component-order
 251     { image-width image-height }       >>dim
 252     pixel-order 0 =                    >>upside-down?
 253     image-data                         >>bitmap
 254     ubyte-components                   >>component-type ;
 255
 256 M: tga-image stream>image*
 257     drop [ [ read-tga ] throw-on-eof ] with-input-stream ;
 258
 259 M: tga-image image>stream
 260     2drop
 261     [
 262         component-order>> { BGRA BGRA } member? [ bad-tga-unsupported ] unless
 263     ] keep
 264
 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
 270     {
 271         [ dim>> first 2 >le write ]
 272         [ dim>> second 2 >le write ]
 273         [ component-order>>
 274           {
 275               {  BGR [ B{ 24 } write ] }
 276               { BGRA [ B{ 32 } write ] }
 277           } case
 278         ]
 279         [
 280             dup component-order>>
 281             {
 282                 {  BGR [ 0 ] }
 283                 { BGRA [ 8 ] }
 284             } case swap
 285             upside-down?>> [ 0 ] [ 2 ] if 3 shift bitor
 286             1 >le write
 287         ]
 288         [ bitmap>> write ]
 289     } cleave ;