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