extra/images/testing/testing.factor

   1 ! Copyright (C) 2009 Keith Lazuka.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays images images.loader
   4 images.normalization images.viewer io io.backend io.directories
   5 io.encodings.binary io.files io.pathnames io.streams.byte-array
   6 kernel namespaces random sequences serialize tools.test ;
   7 IN: images.testing
   8
   9 <PRIVATE
  10
  11 : fig-name ( path -- newpath )
  12     [ parent-directory normalize-path ]
  13     [ file-stem ".fig" append ] bi
  14     append-path ;
  15
  16 PRIVATE>
  17
  18 :: with-matching-files ( dirpath extension quot -- )
  19     dirpath [
  20         [
  21             dup file-extension extension = quot [ drop ] if
  22         ] each
  23     ] with-directory-files ; inline
  24
  25 : images. ( dirpath extension -- )
  26     [ image. ] with-matching-files ;
  27
  28 : ls ( dirpath extension -- )
  29     [ "\"" 1surround print ] with-matching-files ;
  30
  31 : save-as-reference-image ( path -- )
  32     [ load-image ] [ fig-name ] bi
  33     binary [ serialize ] with-file-writer ;
  34
  35 : save-all-as-reference-images ( dirpath extension -- )
  36     [ save-as-reference-image ] with-matching-files ;
  37
  38 : load-reference-image ( path -- image )
  39     fig-name binary [ deserialize ] with-file-reader ;
  40
  41 :: encode-test ( path image-class -- )
  42     f verbose-tests? [
  43         path image-class load-image*
  44         [ clone normalize-image 1array ] keep
  45         '[
  46             binary [
  47                 _ path file-extension image-class image>stream
  48             ] with-byte-writer image-class load-image* normalize-image
  49         ] unit-test
  50     ] with-variable ;
  51
  52 :: decode-test ( path image-class -- )
  53     f verbose-tests? [
  54         path image-class load-image* 1array
  55         [ path load-reference-image ]
  56         unit-test
  57     ] with-variable ;
  58
  59 : <rgb-image> ( -- image )
  60     <image>
  61         RGB >>component-order
  62         ubyte-components >>component-type ; inline
  63
  64 : randomize-image ( image -- image )
  65     dup bytes-per-image random-bytes >>bitmap ;
  66
  67 : image-load-must-fail ( path image-class -- )
  68     '[ _ _ load-image* ] must-fail ;