extra/images/gif/gif.factor

   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 grouping images images.loader io
   5 io.binary io.buffers io.encodings.string io.encodings.utf8
   6 io.ports kernel make math math.bitwise namespaces sequences ;
   7 IN: images.gif
   8
   9 SINGLETON: gif-image
  10 "gif" gif-image register-image-class
  11
  12 TUPLE: loading-gif
  13 loading?
  14 magic
  15 width height
  16 flags
  17 background-color
  18 default-aspect-ratio
  19 global-color-table
  20 graphic-control-extensions
  21 application-extensions
  22 plain-text-extensions
  23 comment-extensions
  24
  25 image-descriptor
  26 local-color-table
  27 compressed-bytes ;
  28
  29 TUPLE: gif-frame
  30 image-descriptor
  31 local-color-table ;
  32
  33 ERROR: unsupported-gif-format magic ;
  34 ERROR: unknown-extension n ;
  35 ERROR: gif-unexpected-eof ;
  36
  37 TUPLE: graphics-control-extension
  38 flags delay-time transparent-color-index ;
  39
  40 TUPLE: image-descriptor
  41 left top width height flags first-code-size ;
  42
  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 ;
  47
  48 TUPLE: application-extension
  49 introducer label block-size identifier authentication-code
  50 application-data ;
  51
  52 TUPLE: comment-extension
  53 introducer label comment-data ;
  54
  55 TUPLE: trailer byte ;
  56 CONSTRUCTOR: trailer ( byte -- obj ) ;
  57
  58 CONSTANT: image-descriptor HEX: 2c
  59 ! Extensions
  60 CONSTANT: extension-identifier HEX: 21
  61 CONSTANT: plain-text-extension HEX: 01
  62 CONSTANT: graphic-control-extension HEX: f9
  63 CONSTANT: comment-extension HEX: fe
  64 CONSTANT: application-extension HEX: ff
  65 CONSTANT: trailer HEX: 3b
  66 CONSTANT: graphic-control-extension-block-size HEX: 04
  67 CONSTANT: block-terminator HEX: 00
  68
  69 : <loading-gif> ( -- loading-gif )
  70     \ loading-gif new
  71         V{ } clone >>graphic-control-extensions
  72         V{ } clone >>application-extensions
  73         V{ } clone >>plain-text-extensions
  74         V{ } clone >>comment-extensions
  75         t >>loading? ;
  76
  77 GENERIC: stream-peek1 ( stream -- byte )
  78
  79 M: input-port stream-peek1
  80     dup check-disposed dup wait-to-read
  81     [ drop f ] [ buffer>> buffer-peek ] if ; inline
  82
  83 : peek1 ( -- byte ) input-stream get stream-peek1 ;
  84
  85 : (read-sub-blocks) ( -- )
  86     read1 [ read , (read-sub-blocks) ] unless-zero ;
  87
  88 : read-sub-blocks ( -- bytes )
  89     [ (read-sub-blocks) ] { } make B{ } concat-as ;
  90
  91 : read-image-descriptor ( -- image-descriptor )
  92     \ image-descriptor new
  93         2 read le> >>left
  94         2 read le> >>top
  95         2 read le> >>width
  96         2 read le> >>height
  97         1 read le> >>flags
  98         1 read le> 1 + >>first-code-size ;
  99
 100 : read-graphic-control-extension ( -- graphic-control-extension )
 101     \ graphics-control-extension new
 102         1 read le> graphic-control-extension-block-size assert=
 103         1 read le> >>flags
 104         2 read le> >>delay-time
 105         1 read le> >>transparent-color-index
 106         1 read le> block-terminator assert= ;
 107
 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 ;
 120
 121 : read-comment-extension ( -- comment-extension )
 122     \ comment-extension new
 123         read-sub-blocks >>comment-data ;
 124
 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 ;
 131
 132 : read-gif-header ( loading-gif -- loading-gif )
 133     6 read utf8 decode >>magic ;
 134
 135 ERROR: unimplemented message ;
 136 : read-GIF87a ( loading-gif -- loading-gif )
 137     "GIF87a" unimplemented ;
 138
 139 : read-logical-screen-descriptor ( loading-gif -- loading-gif )
 140     2 read le> >>width
 141     2 read le> >>height
 142     1 read le> >>flags
 143     1 read le> >>background-color
 144     1 read le> >>default-aspect-ratio ;
 145
 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
 150 : transparency? ( image -- ? )
 151     graphic-control-extensions>> first flags>> 0 bit? ; inline
 152
 153 : color-resolution ( image -- ? ) flags>> -4 shift 3 bits ; inline
 154
 155 : read-global-color-table ( loading-gif -- loading-gif )
 156     dup color-table? [
 157         dup color-table-size read 3 group >>global-color-table
 158     ] when ;
 159
 160 : maybe-read-local-color-table ( loading-gif -- loading-gif )
 161     dup image-descriptor>> color-table? [
 162         dup color-table-size read >>local-color-table
 163     ] when ;
 164
 165 : read-image-data ( loading-gif -- loading-gif )
 166     read-sub-blocks >>compressed-bytes ;
 167
 168 : read-table-based-image ( loading-gif -- loading-gif )
 169     read-image-descriptor >>image-descriptor
 170     maybe-read-local-color-table
 171     read-image-data ;
 172
 173 : read-graphic-rendering-block ( loading-gif -- loading-gif )
 174     read-table-based-image ;
 175
 176 : read-extension ( loading-gif -- loading-gif )
 177     read1 {
 178         { plain-text-extension [
 179             read-plain-text-extension over plain-text-extensions>> push
 180         ] }
 181
 182         { graphic-control-extension [
 183             read-graphic-control-extension
 184             over graphic-control-extensions>> push
 185         ] }
 186         { comment-extension [
 187             read-comment-extension over comment-extensions>> push
 188         ] }
 189         { application-extension [
 190             read-application-extension over application-extensions>> push
 191         ] }
 192         { f [ gif-unexpected-eof ] }
 193         [ unknown-extension ]
 194     } case ;
 195
 196 ERROR: unhandled-data byte ;
 197
 198 : read-data ( loading-gif -- loading-gif )
 199     read1 {
 200         { extension-identifier [ read-extension ] }
 201         { graphic-control-extension [
 202             read-graphic-control-extension
 203             over graphic-control-extensions>> push
 204         ] }
 205         { image-descriptor [ read-table-based-image ] }
 206         { trailer [ f >>loading? ] }
 207         [ unhandled-data ]
 208     } case ;
 209
 210 : read-GIF89a ( loading-gif -- loading-gif )
 211     read-logical-screen-descriptor
 212     read-global-color-table
 213     [ read-data dup loading?>> ] loop ;
 214
 215 : load-gif ( stream -- loading-gif )
 216     [
 217         <loading-gif>
 218         read-gif-header dup magic>> {
 219             { "GIF87a" [ read-GIF87a ] }
 220             { "GIF89a" [ read-GIF89a ] }
 221             [ unsupported-gif-format ]
 222         } case
 223     ] with-input-stream ;
 224
 225 : decompress ( loading-gif -- indexes )
 226     [ compressed-bytes>> ]
 227     [ image-descriptor>> first-code-size>> ] bi
 228     gif-lzw-uncompress ;
 229
 230 : colorize ( index palette transparent-index/f -- seq )
 231     pick = [ 2drop B{ 0 0 0 0 } ] [ nth 255 suffix ] if ;
 232
 233 : apply-palette ( indexes palette transparent-index/f -- bitmap )
 234     [ colorize ] 2curry V{ } map-as concat ;
 235
 236 : dimensions ( loading-gif -- dim )
 237     [ image-descriptor>> width>> ] [ image-descriptor>> height>> ] bi 2array ;
 238
 239 : ?transparent-color-index ( loading-gif -- index/f )
 240     dup transparency?
 241     [ graphic-control-extensions>> first transparent-color-index>> ]
 242     [ drop f ] if ;
 243
 244 : gif>image ( loading-gif -- image )
 245     [ <image> ] dip
 246     [ dimensions >>dim ]
 247     [ drop RGBA >>component-order ubyte-components >>component-type ]
 248     [
 249         [ decompress ] [ global-color-table>> ] [ ?transparent-color-index ] tri
 250         apply-palette >>bitmap
 251     ] tri ;
 252
 253 ERROR: loading-gif-error gif-image ;
 254
 255 : ensure-loaded ( gif-image -- gif-image )
 256     dup loading?>> [ loading-gif-error ] when ;
 257
 258 M: gif-image stream>image ( path gif-image -- image )
 259     drop load-gif ensure-loaded gif>image ;