extra/images/gif/gif-tests.factor

   1 ! Copyright (C) 2009 Keith Lazuka.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors compression.lzw images.gif images.testing io
   4 io.encodings.binary io.files kernel math math.bitwise
   5 namespaces sequences tools.test ;
   6 IN: images.gif.tests
   7
   8 {
   9     "vocab:images/testing/gif/circle.gif"
  10     "vocab:images/testing/gif/checkmark.gif"
  11     "vocab:images/testing/gif/monochrome.gif"
  12     "vocab:images/testing/gif/alpha.gif"
  13     "vocab:images/testing/gif/noise.gif"
  14     "vocab:images/testing/gif/astronaut_animation.gif"
  15 } [ gif-image decode-test ] each
  16
  17 : path>gif ( path -- gif )
  18     binary [ input-stream get load-gif ] with-file-reader ;
  19
  20 : circle.gif ( -- gif )
  21     "vocab:images/testing/gif/circle.gif" path>gif ;
  22
  23 : checkmark.gif ( -- gif )
  24     "vocab:images/testing/gif/checkmark.gif" path>gif ;
  25
  26 : monochrome.gif ( -- gif )
  27     "vocab:images/testing/gif/monochrome.gif" path>gif ;
  28
  29 : alpha.gif ( -- gif )
  30     "vocab:images/testing/gif/alpha.gif" path>gif ;
  31
  32 : declared-num-colors ( gif -- n ) flags>> 3 bits 1 + 2^ ;
  33 : actual-num-colors ( gif -- n ) global-color-table>> length ;
  34
  35 { 2 } [ monochrome.gif actual-num-colors ] unit-test
  36 { 2 } [ monochrome.gif declared-num-colors ] unit-test
  37
  38 { 16 } [ circle.gif actual-num-colors ] unit-test
  39 { 16 } [ circle.gif declared-num-colors ] unit-test
  40
  41 { 256 } [ checkmark.gif actual-num-colors ] unit-test
  42 { 256 } [ checkmark.gif declared-num-colors ] unit-test
  43
  44 : >index-stream ( gif -- seq )
  45     [ compressed-bytes>> ]
  46     [ image-descriptor>> first-code-size>> ] bi
  47     gif-lzw-uncompress ;
  48
  49 {
  50     BV{
  51         0 0 0 0 0 0
  52         1 0 0 0 0 1
  53         1 1 0 0 1 1
  54         1 1 1 1 1 1
  55         1 0 1 1 0 1
  56         1 0 0 0 0 1
  57     }
  58 } [ monochrome.gif >index-stream ] unit-test
  59
  60 {
  61     BV{
  62         0 1
  63         1 0
  64     }
  65 } [ alpha.gif >index-stream ] unit-test