extra/images/gif/gif.factor

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