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 fry 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 locals namespaces quotations random sequences serialize
   7 tools.test ;
   8 IN: images.testing
   9
  10 <PRIVATE
  11
  12 : fig-name ( path -- newpath )
  13     [ parent-directory normalize-path ]
  14     [ file-stem ".fig" append ] bi
  15     append-path ;
  16
  17 PRIVATE>
  18
  19 :: with-matching-files ( dirpath extension quot -- )
  20     dirpath [
  21         [
  22             dup file-extension extension = quot [ drop ] if
  23         ] each
  24     ] with-directory-files ; inline
  25
  26 : images. ( dirpath extension -- )
  27     [ image. ] with-matching-files ;
  28
  29 : ls ( dirpath extension -- )
  30     [ "\"" 1surround print ] with-matching-files ;
  31
  32 : save-as-reference-image ( path -- )
  33     [ load-image ] [ fig-name ] bi
  34     binary [ serialize ] with-file-writer ;
  35
  36 : save-all-as-reference-images ( dirpath extension -- )
  37     [ save-as-reference-image ] with-matching-files ;
  38
  39 : load-reference-image ( path -- image )
  40     fig-name binary [ deserialize ] with-file-reader ;
  41
  42 :: encode-test ( path image-class -- )
  43     f verbose-tests? [
  44         path image-class load-image*
  45         [ clone normalize-image 1array ] keep
  46         '[
  47             binary [
  48                 _ path file-extension image-class image>stream
  49             ] with-byte-writer image-class load-image* normalize-image
  50         ] unit-test
  51     ] with-variable ;
  52
  53 :: decode-test ( path image-class -- )
  54     f verbose-tests? [
  55         path image-class load-image* 1array
  56         [ path load-reference-image ]
  57         unit-test
  58     ] with-variable ;
  59
  60 : <rgb-image> ( -- image )
  61     <image>
  62         RGB >>component-order
  63         ubyte-components >>component-type ; inline
  64
  65 : randomize-image ( image -- image )
  66     dup bytes-per-image random-bytes >>bitmap ;
  67
  68 : image-load-must-fail ( path image-class -- )
  69     '[ _ _ load-image* ] must-fail ;